module SizedIO.IOGraphicsLib where

{-# FOREIGN GHC import qualified Graphics.SOE #-}
{-# FOREIGN GHC import qualified Graphics.Rendering.OpenGL #-}
{-# FOREIGN GHC import qualified GHC.Int #-}
{-# FOREIGN GHC import qualified Foreign.C.Types #-}

open import Data.Bool.Base
open import Data.Char.Base
open import Data.Nat.Base hiding (_+_)
open import Data.List.Base as L
open import Data.Integer.Base
open import Data.Product

open import Data.Maybe.Base

open import Size renaming (Size to AgdaSize)

open import SizedIO.Base

open import NativeIO
open import NativeInt

AgdaPoint = (ℤ × ℤ)

postulate Window : Set
-- {-# COMPILED_TYPE Window Graphics.SOE.Window #-}

postulate Size : Set
-- {-# COMPILED_TYPE Size Graphics.SOE.Size #-}

postulate size : ℤ → ℤ → Size
-- {-# COMPILED size (\ x y -> ( (fromInteger x) :: Int, (fromInteger y) :: Int) :: Graphics.SOE.Size) #-}

postulate Point : Set
-- {-# COMPILED_TYPE Point Graphics.SOE.Point #-}

postulate nativePoint : ℤ → ℤ → Point
-- {-# COMPILED nativePoint (\ x y -> (fromInteger x, fromInteger y)::Graphics.SOE.Point) #-}

postulate nativeProj1Point : Point → ℤ
postulate nativeProj2Point : Point → ℤ
-- {-# COMPILED nativeProj1Point (\(x, y) -> toInteger x) #-}
-- {-# COMPILED nativeProj2Point (\(x, y) -> toInteger y) #-}

{-
toNativePoint : Point → NativePoint
toNativePoint (x , y) = nativePoint x y
-}

data Event : Set where
   Key : Char → Bool → Event
   Button : Point → Bool → Bool → Event
   MouseMove : Point → Event
   Resize : Event
   Closed : Event

-- {-# COMPILED_DATA Event Graphics.SOE.Event Graphics.SOE.Key Graphics.SOE.Button Graphics.SOE.MouseMove Graphics.SOE.Resize Graphics.SOE.Closed #-}

postulate nativeMaybeGetWindowEvent : Window → NativeIO (Maybe Event)
-- {-# COMPILED nativeMaybeGetWindowEvent Graphics.SOE.maybeGetWindowEvent #-}

postulate nativeGetWindowEvent : Window → NativeIO (Event)
-- {-# COMPILED nativeGetWindowEvent Graphics.SOE.getWindowEvent #-}

postulate Graphic : Set
-- {-# COMPILED_TYPE Graphic Graphics.SOE.Graphic #-}

postulate nativeDrawInWindow : Window → Graphic → NativeIO Unit
-- {-# COMPILED nativeDrawInWindow Graphics.SOE.drawInWindow #-}

postulate Word32 : Set
-- {-# COMPILED_TYPE Word32 Graphics.SOE.Word32 #-}

postulate text : Point → String → Graphic
-- {-# COMPILED text (\ p s -> Graphics.SOE.text p (Data.Text.unpack s)) #-}

data RedrawMode : Set where
-- (removed from lib where: DoubleBuffered : RedrawMode, Unbuffered : RedrawMode)

-- {-# COMPILED_DATA RedrawMode Graphics.SOE.RedrawMode #-}

postulate nativeDrawGraphic : RedrawMode
-- {-# COMPILED nativeDrawGraphic Graphics.SOE.drawGraphic #-}

postulate nativeDrawBufferedGraphic : RedrawMode
-- {-# COMPILED nativeDrawBufferedGraphic Graphics.SOE.drawBufferedGraphic #-}

postulate nativeOpenWindow : String → Size → NativeIO Window
-- {-# COMPILED nativeOpenWindow (\ s -> Graphics.SOE.openWindow (Data.Text.unpack s)) #-}

postulate nativeOpenWindowEx : String → (Maybe Point) → (Maybe Size) → RedrawMode → (Maybe Word32) → NativeIO Window
-- {-# COMPILED nativeOpenWindowEx (\s -> Graphics.SOE.openWindowEx (Data.Text.unpack s)) #-}

nativeOpenWindowExNat : String → (Maybe Point) → ℕ → ℕ → RedrawMode → (Maybe Word32) → NativeIO Window
nativeOpenWindowExNat s p n1 n2 a b = nativeOpenWindowEx s p (just (size (+ n1) (+ n2))) a b

postulate nativeCloseWindow : Window → NativeIO Unit
-- {-# COMPILED nativeCloseWindow Graphics.SOE.closeWindow #-}

postulate nativeRunGraphics :  NativeIO Unit → NativeIO Unit
-- {-#  COMPILED nativeRunGraphics Graphics.SOE.runGraphics #-}

postulate word32ToInteger : Word32 → ℤ
-- {-#  COMPILED word32ToInteger (\w -> toInteger (Graphics.SOE.word32ToInt w)) #-}

postulate nativeTimeGetTime : NativeIO Word32
-- {-#  COMPILED nativeTimeGetTime Graphics.SOE.timeGetTime #-}

data Color : Set where
  black   : Color
  blue    : Color
  green   : Color
  cyan    : Color
  red     : Color
  magenta : Color
  yellow  : Color
  white   : Color
-- {-#  COMPILED_DATA Color Graphics.SOE.Color Graphics.SOE.Black Graphics.SOE.Blue Graphics.SOE.Green Graphics.SOE.Cyan Graphics.SOE.Red Graphics.SOE.Magenta Graphics.SOE.Yellow Graphics.SOE.White #-}

postulate withColor : Color → Graphic → Graphic
-- {-#  COMPILED withColor Graphics.SOE.withColor #-}

postulate polygon : List Point → Graphic
-- {-#  COMPILED polygon Graphics.SOE.polygon #-}

{-
polygon : List Point → Graphic
polygon l = nativePolygon (L.map toNativePoint l)
-}

data GraphicsCommands : Set where
  closeWindow         : Window            → GraphicsCommands
  maybeGetWindowEvent : Window            → GraphicsCommands
  getWindowEvent      : Window            → GraphicsCommands
  openWindowNotEx     : String → Size    → GraphicsCommands
  openWindow          : String → (Maybe Point) → ℕ → ℕ
                        → RedrawMode → (Maybe Word32) → GraphicsCommands
  timeGetTime         :                      GraphicsCommands
  drawInWindow        : Window → Graphic → GraphicsCommands
  print               : String →             GraphicsCommands

GraphicsResponses : GraphicsCommands → Set
GraphicsResponses (maybeGetWindowEvent w) = Maybe Event
GraphicsResponses (getWindowEvent w)      = Event
GraphicsResponses (closeWindow w)         = Unit
GraphicsResponses (openWindowNotEx s s')  = Window
GraphicsResponses (openWindow s n1 n2 s' r w) = Window
GraphicsResponses timeGetTime             = Word32
GraphicsResponses _                       = Unit

GraphicsInterface : IOInterface
Command  GraphicsInterface = GraphicsCommands
Response GraphicsInterface = GraphicsResponses

IOGraphics : AgdaSize → Set → Set
IOGraphics i = IO GraphicsInterface i

IOGraphics+ : AgdaSize → Set → Set
IOGraphics+ i = IO+ GraphicsInterface i

translateIOGraphicsLocal : (c : GraphicsCommands) → NativeIO (GraphicsResponses c)
translateIOGraphicsLocal (maybeGetWindowEvent w) = nativeMaybeGetWindowEvent w
translateIOGraphicsLocal (getWindowEvent w)      = nativeGetWindowEvent w
translateIOGraphicsLocal (closeWindow w)         = nativeCloseWindow w
translateIOGraphicsLocal (openWindowNotEx str size)   = nativeOpenWindow str size
translateIOGraphicsLocal (openWindow str point n1 n2 mode word) = nativeOpenWindowExNat str point n1 n2 mode word
translateIOGraphicsLocal timeGetTime             = nativeTimeGetTime
translateIOGraphicsLocal (drawInWindow w g)      = nativeDrawInWindow w g
translateIOGraphicsLocal (print s)             = nativePutStrLn s

translateIOGraphics : {A : Set} → IOGraphics ∞ A → NativeIO A
translateIOGraphics = translateIO translateIOGraphicsLocal


-- {-# OPTIONS -v 20 #-}
-- {-# OPTIONS -v tc.polarity:30 #-}
-- {-# OPTIONS -v tc.decl:30 #-}
-- {-# OPTIONS -v tc.term:30 #-}
-- {-# OPTIONS -v tc.conv.coerce:20 #-}
-- {-# OPTIONS -v tc.signature:30 #-}
-- {-# OPTIONS -v import.iface:100 #-}

module Issue1168 where

open import Agda.Primitive
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

id : ∀{a} {A : Set a} → A → A
id {A = A} a = a

id2 : ∀{A : id Set} → id A → A
id2 x = x

plus0 : ∀ x → x + 0 ≡ x
plus0 zero = refl
plus0 (suc x) rewrite plus0 x = refl

Identity : ∀{a} {A : Set a} (f : A → A) → Set a
Identity f = ∀ x → f x ≡ x

plus-0 : Identity (_+ 0)
plus-0 = plus0

my-Fun : ∀{a b} (A : Set a) (F : A → Set b) → Set (a ⊔ b)
my-Fun A F = (x : A) → F x

syntax my-Fun A (λ x → B) = [ x ∷ A ]=> B

my-id : [ A ∷ Set ]=> [ x ∷ A ]=> A
my-id A x = x


-- Andreas, 2016-11-03, issue #2292
-- Internal error when debugging the coverage checker.

{-# OPTIONS -v tc.cover.top:10 #-} -- KEEP!

data ⊥ : Set where

⊥-elim : ∀{A : Set} → ⊥ → A
⊥-elim ()


open import Coinduction using ( ♯_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; subst )
open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; ⟦_⟧ ; _≃_ )
open import System.IO.Transducers.Strict using ( Strict )
open import System.IO.Transducers.Session using ( Session ; I ; Σ ; _/_ )
open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ; _✓ ; _⊑_ )
open import System.IO.Transducers.Properties.Lemmas using ( I-η ; ⟦⟧-mono ; ⟦⟧-resp-✓ ; ⟦⟧-resp-[] )
open import System.IO.Transducers.Properties.Category using ( _≣_ ; ⟦⟧-refl-≣ )

module System.IO.Transducers.Properties.Equivalences where

open Relation.Binary.PropositionalEquality.≡-Reasoning

_//_ : ∀ S → (Trace S) → Session
S // [] = S
S // (a ∷ as) = (S / a) // as

suffix : ∀ {S} {as bs : Trace S} → (as ⊑ bs) → (Trace (S // as))
suffix {bs = bs} [] = bs
suffix (a ∷ as⊑bs) = suffix as⊑bs

_+++_ : ∀ {S} (as : Trace S) (bs : Trace (S // as)) → (Trace S)
[]       +++ bs = bs
(a ∷ as) +++ bs = a ∷ (as +++ bs)

suffix-+++ : ∀ {S} {as : Trace S} {bs} (as⊑bs : as ⊑ bs) →
  as +++ suffix as⊑bs ≡ bs
suffix-+++ []          = refl
suffix-+++ (a ∷ as⊑bs) = cong (_∷_ a) (suffix-+++ as⊑bs)

suffix-mono : ∀ {S} {as : Trace S} {bs cs} (as⊑bs : as ⊑ bs) (as⊑cs : as ⊑ cs) →
  (bs ⊑ cs) → (suffix as⊑bs ⊑ suffix as⊑cs)
suffix-mono []           []           bs⊑cs       = bs⊑cs
suffix-mono (.a ∷ as⊑bs) (.a ∷ as⊑cs) (a ∷ bs⊑cs) = suffix-mono as⊑bs as⊑cs bs⊑cs

suffix-resp-✓ : ∀ {S} {as : Trace S} {bs} (as⊑bs : as ⊑ bs) →
  (bs ✓) → (suffix as⊑bs ✓)
suffix-resp-✓ []           bs✓       = bs✓
suffix-resp-✓ (.a ∷ as⊑bs) (a ∷ bs✓) = suffix-resp-✓ as⊑bs bs✓

suffix-[] : ∀ {S} {as : Trace S} (as⊑as : as ⊑ as) →
  (suffix as⊑as ≡ [])
suffix-[] [] = refl
suffix-[] (a ∷ as⊑as) = suffix-[] as⊑as

strictify : ∀ {S T} (f : Trace S → Trace T) →
  (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
    (Trace S → Trace (T // f []))
strictify f f-mono as = suffix (f-mono [] as [])

lazify : ∀ {S T} (f : Trace S → Trace T) a →
  (Trace (S / a) → Trace T)
lazify f a as = f (a ∷ as)

strictify-mono : ∀ {S T} (f : Trace S → Trace T) f-mono →
  (∀ as bs → as ⊑ bs → strictify f f-mono as ⊑ strictify f f-mono bs)
strictify-mono f f-mono as bs as⊑bs = suffix-mono (f-mono [] as []) (f-mono [] bs []) (f-mono as bs as⊑bs)

strictify-resp-✓ : ∀ {S T} (f : Trace S → Trace T) f-mono →
  (∀ as → as ✓ → f as ✓) →
    (∀ as → as ✓ → strictify f f-mono as ✓)
strictify-resp-✓ f f-mono f-resp-✓ as as✓ = suffix-resp-✓ (f-mono [] as []) (f-resp-✓ as as✓)

strictify-strict : ∀ {S T} (f : Trace S → Trace T) f-mono →
  (strictify f f-mono [] ≡ [])
strictify-strict f f-mono = suffix-[] (f-mono [] [] [])

lazify-mono : ∀ {S T} (f : Trace S → Trace T) a →
  (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
    (∀ as bs → as ⊑ bs → lazify f a as ⊑ lazify f a bs)
lazify-mono f a f-mono as bs as⊑bs = f-mono (a ∷ as) (a ∷ bs) (a ∷ as⊑bs)

lazify-resp-✓ : ∀ {S T} (f : Trace S → Trace T) a →
  (∀ as → as ✓ → f as ✓) →
    (∀ as → as ✓ → lazify f a as ✓)
lazify-resp-✓ f a f-resp-✓ as as✓ = f-resp-✓ (a ∷ as) (a ∷ as✓)

mutual

  lazy' : ∀ {T S} bs (f : Trace S → Trace (T // bs)) →
    (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
      (∀ as → as ✓ → f as ✓) → (f [] ≡ []) →
        (S ⇒ T)
  lazy' [] f f-mono f-resp-✓ f-strict = strict f f-mono f-resp-✓ f-strict
  lazy' {Σ V F} (b ∷ bs) f f-mono f-resp-✓ f-strict = out b (lazy' bs f f-mono f-resp-✓ f-strict)
  lazy' {I} (() ∷ bs) f f-mono f-resp-✓ f-strict

  lazy : ∀ {T S} (f : Trace S → Trace T) →
    (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
      (∀ as → as ✓ → f as ✓) →
        (S ⇒ T)
  lazy f f-mono f-resp-✓ = lazy' (f []) (strictify f f-mono) (strictify-mono f f-mono) (strictify-resp-✓ f f-mono f-resp-✓) (strictify-strict f f-mono)

  strict : ∀ {S T} (f : Trace S → Trace T) →
    (∀ as bs → as ⊑ bs → f as ⊑ f bs) →
      (∀ as → as ✓ → f as ✓) → (f [] ≡ []) →
        (S ⇒ T)
  strict {I} {I} f f-mono f-resp-✓ f-strict = done
  strict {Σ V F} f f-mono f-resp-✓ f-strict = inp (♯ λ a → lazy (lazify f a) (lazify-mono f a f-mono) (lazify-resp-✓ f a f-resp-✓))
  strict {I} {Σ W G} f f-mono f-resp-✓ f-strict with subst _✓ f-strict (f-resp-✓ [] [])
  strict {I} {Σ W G} f f-mono f-resp-✓ f-strict | ()

mutual

  lazy'-⟦⟧ : ∀ {T S} bs (f : Trace S → Trace (T // bs)) f-mono f-resp-✓ f-strict →
    ∀ as → ⟦ lazy' bs f f-mono f-resp-✓ f-strict ⟧ as ≡ bs +++ f as
  lazy'-⟦⟧ [] f f-mono f-resp-✓ f-strict as = strict-⟦⟧ f f-mono f-resp-✓ f-strict as
  lazy'-⟦⟧ {Σ W G} (b ∷ bs)  f f-mono f-resp-✓ f-strict as = cong (_∷_ b) (lazy'-⟦⟧ bs f f-mono f-resp-✓ f-strict as)
  lazy'-⟦⟧ {I}     (() ∷ bs) f f-mono f-resp-✓ f-strict as

  lazy-⟦⟧ : ∀ {S T} (f : Trace S → Trace T) f-mono f-resp-✓ →
    ⟦ lazy f f-mono f-resp-✓ ⟧ ≃ f
  lazy-⟦⟧ f f-mono f-resp-✓ as =
    begin
      ⟦ lazy f f-mono f-resp-✓ ⟧ as
    ≡⟨ lazy'-⟦⟧ (f []) (strictify f f-mono) (strictify-mono f f-mono) (strictify-resp-✓ f f-mono f-resp-✓) (strictify-strict f f-mono) as ⟩
      f [] +++ strictify f f-mono as
    ≡⟨ suffix-+++ (f-mono [] as []) ⟩
      f as
    ∎

  strict-⟦⟧ : ∀ {S T} (f : Trace S → Trace T) f-mono f-resp-✓ f-strict →
    ⟦ strict f f-mono f-resp-✓ f-strict ⟧ ≃ f
  strict-⟦⟧ {I} {I} f f-mono f-resp-✓ f-strict [] = sym (I-η (f []))
  strict-⟦⟧ {Σ V F} f f-mono f-resp-✓ f-strict [] = sym f-strict
  strict-⟦⟧ {Σ V F} f f-mono f-resp-✓ f-strict (a ∷ as) = lazy-⟦⟧ (lazify f a) (lazify-mono f a f-mono) (lazify-resp-✓ f a f-resp-✓) as
  strict-⟦⟧ {I} {Σ W G} f f-mono f-resp-✓ f-strict as with subst _✓ f-strict (f-resp-✓ [] [])
  strict-⟦⟧ {I} {Σ W G} f f-mono f-resp-✓ f-strict as | ()
  strict-⟦⟧ {I} f f-mono f-resp-✓ f-strict (() ∷ as)

⟦⟧-lazy : ∀ {S T} (P : S ⇒ T) →
  lazy ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) ≣ P
⟦⟧-lazy P = ⟦⟧-refl-≣ (lazy ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P)) P (lazy-⟦⟧ ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P))

⟦⟧-strict : ∀ {S T} (P : S ⇒ T) (#P : Strict P) →
  strict ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P) ≣ P
⟦⟧-strict P #P = ⟦⟧-refl-≣ (strict ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P)) P (strict-⟦⟧ ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P))


module Issue1760a where

-- Skipping a single record definition.
{-# NO_POSITIVITY_CHECK #-}
record U : Set where
  field ap : U → U


{-# OPTIONS --no-termination-check #-}
module SafeFlagNoTermination where

data Empty : Set where

inhabitant : Empty
inhabitant = inhabitant


------------------------------------------------------------------------
-- Equivalence of the two variants of declarative kinding of Fω with
-- interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Declarative.Equivalence where

open import Data.Product using (proj₁)

open import FOmegaInt.Syntax
import FOmegaInt.Typing                   as Original
open import FOmegaInt.Kinding.Declarative as Extended
open import FOmegaInt.Kinding.Declarative.Validity

private
  module O where
    open Original public
    open Typing   public

  module E where
    open Extended public
    open Kinding  public

open Syntax
open TermCtx
open Kinding
open KindedSubstitution
open Original.Typing
  hiding (_ctx; _⊢_wf; _⊢_kd; _⊢Tp_∈_; _⊢_<∷_; _⊢_<:_∈_; _⊢_≅_; _⊢_≃_∈_)

-- Soundness of extended declarative (sub)kinding w.r.t. original
-- declarative (sub)kinding.
--
-- This soundness proof simply forgets about all the validity
-- conditions in the extended rules.

mutual

  sound-wf : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢ a wf → Γ O.⊢ a wf
  sound-wf (wf-kd k-kd) = wf-kd (sound-kd k-kd)
  sound-wf (wf-tp a∈*)  = wf-tp (sound-Tp∈ a∈*)

  sound-ctx : ∀ {n} {Γ : Ctx n} → Γ ctx → Γ O.ctx
  sound-ctx E.[]             = O.[]
  sound-ctx (a-wf E.∷ Γ-ctx) = sound-wf a-wf O.∷ sound-ctx Γ-ctx

  sound-kd : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ O.⊢ k kd
  sound-kd (kd-⋯ a∈* b∈*)   = kd-⋯ (sound-Tp∈ a∈*) (sound-Tp∈ b∈*)
  sound-kd (kd-Π j-kd k-kd) = kd-Π (sound-kd j-kd) (sound-kd k-kd)

  sound-Tp∈ : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Tp a ∈ k → Γ O.⊢Tp a ∈ k
  sound-Tp∈ (∈-var x Γ-ctx Γ[x]≡kd-k) =
    ∈-var x (sound-ctx Γ-ctx) Γ[x]≡kd-k
  sound-Tp∈ (∈-⊥-f Γ-ctx)         = ∈-⊥-f (sound-ctx Γ-ctx)
  sound-Tp∈ (∈-⊤-f Γ-ctx)         = ∈-⊤-f (sound-ctx Γ-ctx)
  sound-Tp∈ (∈-∀-f k-kd a∈*)      = ∈-∀-f (sound-kd k-kd) (sound-Tp∈ a∈*)
  sound-Tp∈ (∈-→-f a∈* b∈*)       = ∈-→-f (sound-Tp∈ a∈*) (sound-Tp∈ b∈*)
  sound-Tp∈ (∈-Π-i j-kd a∈k k-kd) = ∈-Π-i (sound-kd j-kd) (sound-Tp∈ a∈k)
  sound-Tp∈ (∈-Π-e a∈Πjk b∈j k-kd k[b]-kd) =
    ∈-Π-e (sound-Tp∈ a∈Πjk) (sound-Tp∈ b∈j)
  sound-Tp∈ (∈-s-i a∈b⋯c)     = ∈-s-i (sound-Tp∈ a∈b⋯c)
  sound-Tp∈ (∈-⇑ a∈j j<∷k)    = ∈-⇑ (sound-Tp∈ a∈j) (sound-<∷ j<∷k)

  sound-<∷ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ j <∷ k → Γ O.⊢ j <∷ k
  sound-<∷ (<∷-⋯ a₂<:a₁∈* b₁<:b₂∈*)      =
    <∷-⋯ (sound-<: a₂<:a₁∈*) (sound-<: b₁<:b₂∈*)
  sound-<∷ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) =
    <∷-Π (sound-<∷ j₂<∷j₁) (sound-<∷ k₁<∷k₂) (sound-kd Πj₁k₁-kd)

  sound-<: : ∀ {n} {Γ : Ctx n} {a b k} → Γ ⊢ a <: b ∈ k → Γ O.⊢ a <: b ∈ k
  sound-<: (<:-refl a∈k) = <:-refl (sound-Tp∈ a∈k)
  sound-<: (<:-trans a<:b∈k b<:c∈k) =
    <:-trans (sound-<: a<:b∈k) (sound-<: b<:c∈k)
  sound-<: (<:-β₁ a∈k b∈j a[b]∈k[b] k-kd k[b]-kd) =
    <:-β₁ (sound-Tp∈ a∈k) (sound-Tp∈ b∈j)
  sound-<: (<:-β₂ a∈k b∈j a[b]∈k[b] k-kd k[b]-kd) =
    <:-β₂ (sound-Tp∈ a∈k) (sound-Tp∈ b∈j)
  sound-<: (<:-η₁ a∈Πjk) = <:-η₁ (sound-Tp∈ a∈Πjk)
  sound-<: (<:-η₂ a∈Πjk) = <:-η₂ (sound-Tp∈ a∈Πjk)
  sound-<: (<:-⊥ a∈b⋯c)  = <:-⊥ (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-⊤ a∈b⋯c)  = <:-⊤ (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-∀ k₂<∷k₁ a₁<:a₂∈* ∀k₁a₁∈*) =
    <:-∀ (sound-<∷ k₂<∷k₁) (sound-<: a₁<:a₂∈*) (sound-Tp∈ ∀k₁a₁∈*)
  sound-<: (<:-→ a₂<:a₁∈* b₁<:b₂∈*) =
    <:-→ (sound-<: a₂<:a₁∈*) (sound-<: b₁<:b₂∈*)
  sound-<: (<:-λ a₁<:a₂∈Πjk Λj₁a₁∈Πjk Λj₂a₂∈Πjk) =
    <:-λ (sound-<: a₁<:a₂∈Πjk)
         (sound-Tp∈ Λj₁a₁∈Πjk) (sound-Tp∈ Λj₂a₂∈Πjk)
  sound-<: (<:-· a₁<:a₂∈Πjk b₁≃b₁∈j b₁∈j k-kd k[b₁]-kd) =
    <:-· (sound-<: a₁<:a₂∈Πjk) (sound-≃ b₁≃b₁∈j)
  sound-<: (<:-⟨| a∈b⋯c)        = <:-⟨| (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-|⟩ a∈b⋯c)        = <:-|⟩ (sound-Tp∈ a∈b⋯c)
  sound-<: (<:-⋯-i a₁<:a₂∈b⋯c)  = <:-⋯-i (sound-<: a₁<:a₂∈b⋯c)
  sound-<: (<:-⇑ a₁<:a₂∈j j<∷k) =
    <:-⇑ (sound-<: a₁<:a₂∈j) (sound-<∷ j<∷k)

  sound-≃ : ∀ {n} {Γ : Ctx n} {a b k} → Γ ⊢ a ≃ b ∈ k → Γ O.⊢ a ≃ b ∈ k
  sound-≃ (<:-antisym a<:b∈k b<:a∈k) =
    <:-antisym (sound-<: a<:b∈k) (sound-<: b<:a∈k)

sound-≅ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ j ≅ k → Γ O.⊢ j ≅ k
sound-≅ (<∷-antisym j<∷k k<∷j) =
  <∷-antisym (sound-<∷ j<∷k) (sound-<∷ k<∷j)

-- Completeness of extended declarative (sub)kinding w.r.t. original
-- declarative (sub)kinding.
--
-- This proves that the validity conditions in the extended rules are
-- in fact redundant, i.e. they follow from validity properties of the
-- remaining premises (of the rules in question)

mutual

  complete-wf : ∀ {n} {Γ : Ctx n} {a} → Γ O.⊢ a wf → Γ ⊢ a wf
  complete-wf (wf-kd k-kd) = wf-kd (complete-kd k-kd)
  complete-wf (wf-tp a∈*)  = wf-tp (complete-Tp∈ a∈*)

  complete-ctx : ∀ {n} {Γ : Ctx n} → Γ O.ctx → Γ ctx
  complete-ctx O.[]             = E.[]
  complete-ctx (a-wf O.∷ Γ-ctx) = complete-wf a-wf E.∷ complete-ctx Γ-ctx

  complete-kd : ∀ {n} {Γ : Ctx n} {k} → Γ O.⊢ k kd → Γ ⊢ k kd
  complete-kd (kd-⋯ a∈* b∈*)   = kd-⋯ (complete-Tp∈ a∈*) (complete-Tp∈ b∈*)
  complete-kd (kd-Π j-kd k-kd) = kd-Π (complete-kd j-kd) (complete-kd k-kd)

  complete-Tp∈ : ∀ {n} {Γ : Ctx n} {a k} → Γ O.⊢Tp a ∈ k → Γ ⊢Tp a ∈ k
  complete-Tp∈ (∈-var x Γ-ctx Γ[x]≡kd-k) =
    ∈-var x (complete-ctx Γ-ctx) Γ[x]≡kd-k
  complete-Tp∈ (∈-⊥-f Γ-ctx)     = ∈-⊥-f (complete-ctx Γ-ctx)
  complete-Tp∈ (∈-⊤-f Γ-ctx)     = ∈-⊤-f (complete-ctx Γ-ctx)
  complete-Tp∈ (∈-∀-f k-kd a∈*)  = ∈-∀-f (complete-kd k-kd) (complete-Tp∈ a∈*)
  complete-Tp∈ (∈-→-f a∈* b∈*)   = ∈-→-f (complete-Tp∈ a∈*) (complete-Tp∈ b∈*)
  complete-Tp∈ (∈-Π-i j-kd a∈k)  =
    ∈-Π-i (complete-kd j-kd) a∈k′ k-kd
    where
      a∈k′ = complete-Tp∈ a∈k
      k-kd = Tp∈-valid a∈k′
  complete-Tp∈ (∈-Π-e a∈Πjk b∈j) with Tp∈-valid (complete-Tp∈ a∈Πjk)
  ... | (kd-Π j-kd k-kd) =
    ∈-Π-e (complete-Tp∈ a∈Πjk) b∈j′ k-kd k[b]-kd
    where
      b∈j′    = complete-Tp∈ b∈j
      k[b]-kd = kd-[] k-kd (∈-tp b∈j′)
  complete-Tp∈ (∈-s-i a∈b⋯c)     = ∈-s-i (complete-Tp∈ a∈b⋯c)
  complete-Tp∈ (∈-⇑ a∈j j<∷k)    = ∈-⇑ (complete-Tp∈ a∈j) (complete-<∷ j<∷k)

  complete-<∷ : ∀ {n} {Γ : Ctx n} {j k} → Γ O.⊢ j <∷ k → Γ ⊢ j <∷ k
  complete-<∷ (<∷-⋯ a₂<:a₁∈* b₁<:b₂∈*)      =
    <∷-⋯ (complete-<: a₂<:a₁∈*) (complete-<: b₁<:b₂∈*)
  complete-<∷ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) =
    <∷-Π (complete-<∷ j₂<∷j₁) (complete-<∷ k₁<∷k₂) (complete-kd Πj₁k₁-kd)

  complete-<: : ∀ {n} {Γ : Ctx n} {a b k} → Γ O.⊢ a <: b ∈ k → Γ ⊢ a <: b ∈ k
  complete-<: (<:-refl a∈k) = <:-refl (complete-Tp∈ a∈k)
  complete-<: (<:-trans a<:b∈k b<:c∈k) =
    <:-trans (complete-<: a<:b∈k) (complete-<: b<:c∈k)
  complete-<: (<:-β₁ a∈k b∈j) =
    <:-β₁ a∈k′ b∈j′ a[b]∈k[b] k-kd k[b]-kd
    where
      a∈k′ = complete-Tp∈ a∈k
      b∈j′ = complete-Tp∈ b∈j
      k-kd = Tp∈-valid a∈k′
      a[b]∈k[b] = Tp∈-[] a∈k′ (∈-tp b∈j′)
      k[b]-kd   = kd-[] k-kd (∈-tp b∈j′)
  complete-<: (<:-β₂ a∈k b∈j) =
    <:-β₂ a∈k′ b∈j′ a[b]∈k[b] k-kd k[b]-kd
    where
      a∈k′ = complete-Tp∈ a∈k
      b∈j′ = complete-Tp∈ b∈j
      k-kd = Tp∈-valid a∈k′
      a[b]∈k[b] = Tp∈-[] a∈k′ (∈-tp b∈j′)
      k[b]-kd   = kd-[] k-kd (∈-tp b∈j′)
  complete-<: (<:-η₁ a∈Πjk) = <:-η₁ (complete-Tp∈ a∈Πjk)
  complete-<: (<:-η₂ a∈Πjk) = <:-η₂ (complete-Tp∈ a∈Πjk)
  complete-<: (<:-⊥ a∈b⋯c)  = <:-⊥ (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-⊤ a∈b⋯c)  = <:-⊤ (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-∀ k₂<∷k₁ a₁<:a₂∈* ∀k₁a₁∈*) =
    <:-∀ (complete-<∷ k₂<∷k₁) (complete-<: a₁<:a₂∈*) (complete-Tp∈ ∀k₁a₁∈*)
  complete-<: (<:-→ a₂<:a₁∈* b₁<:b₂∈*) =
    <:-→ (complete-<: a₂<:a₁∈*) (complete-<: b₁<:b₂∈*)
  complete-<: (<:-λ a₁<:a₂∈Πjk Λj₁a₁∈Πjk Λj₂a₂∈Πjk) =
    <:-λ (complete-<: a₁<:a₂∈Πjk)
         (complete-Tp∈ Λj₁a₁∈Πjk) (complete-Tp∈ Λj₂a₂∈Πjk)
  complete-<: (<:-· a₁<:a₂∈Πjk b₁≃b₁∈j)
    with <:-valid-kd (complete-<: a₁<:a₂∈Πjk)
  ... | (kd-Π j-kd k-kd) =
    <:-· (complete-<: a₁<:a₂∈Πjk) b₁≃b₂∈j′ b₁∈j k-kd k[b₁]-kd
    where
      b₁≃b₂∈j′ = complete-≃ b₁≃b₁∈j
      b₁∈j     = proj₁ (≃-valid b₁≃b₂∈j′)
      k[b₁]-kd = kd-[] k-kd (∈-tp b₁∈j)
  complete-<: (<:-⟨| a∈b⋯c)        = <:-⟨| (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-|⟩ a∈b⋯c)        = <:-|⟩ (complete-Tp∈ a∈b⋯c)
  complete-<: (<:-⋯-i a₁<:a₂∈b⋯c)  = <:-⋯-i (complete-<: a₁<:a₂∈b⋯c)
  complete-<: (<:-⇑ a₁<:a₂∈j j<∷k) =
    <:-⇑ (complete-<: a₁<:a₂∈j) (complete-<∷ j<∷k)

  complete-≃ : ∀ {n} {Γ : Ctx n} {a b k} → Γ O.⊢ a ≃ b ∈ k → Γ ⊢ a ≃ b ∈ k
  complete-≃ (<:-antisym a<:b∈k b<:a∈k) =
    <:-antisym (complete-<: a<:b∈k) (complete-<: b<:a∈k)

complete-≅ : ∀ {n} {Γ : Ctx n} {j k} → Γ O.⊢ j ≅ k → Γ ⊢ j ≅ k
complete-≅ (<∷-antisym j<∷k k<∷j) =
  <∷-antisym (complete-<∷ j<∷k) (complete-<∷ k<∷j)


{- 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.Prelude

module LibraBFT.ImplShared.Util.Dijkstra.EitherD where

data EitherD (E : Set) : Set → Set₁ where
  -- Primitive combinators
  EitherD-return : ∀ {A} → A → EitherD E A
  EitherD-bind   : ∀ {A B} → EitherD E A → (A → EitherD E B) → EitherD E B
  EitherD-bail   : ∀ {A} → E → EitherD E A
  -- Branching conditionals (used for creating more convenient contracts)
  EitherD-if     : ∀ {A} → Guards (EitherD E A) → EitherD E A
  EitherD-either : ∀ {A B C} → Either B C
                   → (B → EitherD E A) → (C → EitherD E A) → EitherD E A
  EitherD-maybe  : ∀ {A B} → Maybe A → EitherD E B → (A → EitherD E B) → EitherD E B

pattern LeftD  x = EitherD-bail   x
pattern RightD x = EitherD-return x

private
  variable
    E : Set
    A B C : Set

EitherD-run : EitherD E A → Either E A
EitherD-run (EitherD-return x) = Right x
EitherD-run (EitherD-bind m f)
  with EitherD-run m
... | Left x = Left x
... | Right y = EitherD-run (f y)
EitherD-run (EitherD-bail x) = Left x
EitherD-run (EitherD-if (clause (b ≔ c) gs)) =
  if toBool b then EitherD-run c else EitherD-run (EitherD-if gs)
EitherD-run (EitherD-if (otherwise≔ c)) =
  EitherD-run c
EitherD-run (EitherD-either (Left x) f₁ f₂) = EitherD-run (f₁ x)
EitherD-run (EitherD-either (Right y) f₁ f₂) = EitherD-run (f₂ y)
EitherD-run (EitherD-maybe nothing n s) = EitherD-run n
EitherD-run (EitherD-maybe (just x) n s) = EitherD-run (s x)

EitherD-Pre : (E A : Set) → Set₁
EitherD-Pre E A = Set

EitherD-Post : (E A : Set) → Set₁
EitherD-Post E A = Either E A → Set

EitherD-PredTrans : (E A : Set) → Set₁
EitherD-PredTrans E A = EitherD-Post E A → EitherD-Pre E A

EitherD-weakestPre-bindPost : (f : A → EitherD E B) → EitherD-Post E B → EitherD-Post E A

EitherD-weakestPre : (m : EitherD E A) → EitherD-PredTrans E A
EitherD-weakestPre (EitherD-return x) P = P (Right x)
EitherD-weakestPre (EitherD-bind m f) P =
  EitherD-weakestPre m (EitherD-weakestPre-bindPost f P)
EitherD-weakestPre (EitherD-bail x) P = P (Left x)
EitherD-weakestPre (EitherD-if (clause (b ≔ c) gs)) P =
  (toBool b ≡ true → EitherD-weakestPre c P)
  × (toBool b ≡ false → EitherD-weakestPre (EitherD-if gs) P)
EitherD-weakestPre (EitherD-if (otherwise≔ x)) P =
  EitherD-weakestPre x P
EitherD-weakestPre (EitherD-either e f₁ f₂) P =
  (∀ x → e ≡ Left x → EitherD-weakestPre (f₁ x) P)
  × (∀ y → e ≡ Right y → EitherD-weakestPre (f₂ y) P)
EitherD-weakestPre (EitherD-maybe m n s) P =
  (m ≡ nothing → EitherD-weakestPre n P)
  × (∀ j → m ≡ just j → EitherD-weakestPre (s j) P)

EitherD-weakestPre-bindPost f P (Left x) =
  P (Left x)
EitherD-weakestPre-bindPost f P (Right y) =
  ∀ c → c ≡ y → EitherD-weakestPre (f c) P

EitherD-Contract : (m : EitherD E A) → Set₁
EitherD-Contract{E}{A} m =
  (P : EitherD-Post E A)
  → EitherD-weakestPre m P → P (EitherD-run m)

EitherD-contract : (m : EitherD E A) → EitherD-Contract m
EitherD-contract (EitherD-return x) P wp = wp
EitherD-contract (EitherD-bind m f) P wp
   with EitherD-contract m _ wp
...| wp'
   with EitherD-run m
... | Left x = wp'
... | Right y = EitherD-contract (f y) P (wp' y refl)
EitherD-contract (EitherD-bail x) P wp = wp
EitherD-contract{E}{A} (EitherD-if gs) P wp =
  EitherD-contract-if gs P wp
  where
  EitherD-contract-if : (gs : Guards (EitherD E A)) → EitherD-Contract (EitherD-if gs)
  EitherD-contract-if (clause (b ≔ c) gs) P wp
     with toBool b
  ... | false = EitherD-contract-if gs P (proj₂ wp refl)
  ... | true = EitherD-contract c P (proj₁ wp refl)
  EitherD-contract-if (otherwise≔ x) P wp = EitherD-contract x P wp
EitherD-contract (EitherD-either (Left x) f₁ f₂) P wp =
  EitherD-contract (f₁ x) P (proj₁ wp x refl)
EitherD-contract (EitherD-either (Right y) f₁ f₂) P wp =
  EitherD-contract (f₂ y) P (proj₂ wp y refl)
EitherD-contract (EitherD-maybe nothing f₁ f₂) P wp =
  EitherD-contract f₁ P (proj₁ wp refl)
EitherD-contract (EitherD-maybe (just x) f₁ f₂) P wp =
  EitherD-contract (f₂ x) P (proj₂ wp x refl)


open import Data.Product using ( ∃ ; _×_ ; _,_ ; proj₁ ; proj₂ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox using ( ABox )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; _*_ )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; ≲-trans ; _**_ ; _≋_ )
open import Web.Semantic.DL.KB using ( KB ; _,_ ; tbox )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( _,_ )
open import Web.Semantic.Util using ( _⊕_⊕_ ; inode ; enode )

module Web.Semantic.DL.Integrity {Σ : Signature} {X V Y : Set} where

-- A variant of the notion of OWL integrity in:

--   Boris Motik, Ian Horrocks, and Ulrike Sattler. Bridging the gap between OWL and
--   relational databases. In Proc. Conf. World Wide Web (WWW2007), pp 807–816, 2007.

-- They propose defining that an integrity constraint S (given as a T-Box) is valid
-- for a knowlege base K whenever S is valid in every minimal Herbrand model.
-- We strengthen this requirement to say that there is a minimal model of K,
-- which validtes S.

infixr 4 _>>_ _,_
infix 2 _⊕_⊨_

-- J ∈ Initial I K whenever J is the initial extension of I
-- satisfying K, that is there is I≲J s.t. I ⊨ K
-- and for any other such I≲K, there is a unique
-- J≲K which commutes with I≲J and I≲K.

_>>_ : ∀ {I : Interp Σ X} {J K : Interp Σ (X ⊕ V ⊕ Y)} →
  (I ≲ inode * J) → (J ≲ K) → (I ≲ inode * K)
I≲J >> J≲K = ≲-trans I≲J (inode ** J≲K)

Unique : ∀ (I : Interp Σ X) → (J K : Interp Σ (X ⊕ V ⊕ Y)) →
  (I ≲ inode * J) → (I ≲ inode * K) → Set
Unique I J K I≲J I≲K = ∀ (J≲₁K J≲₂K : J ≲ K) →
  (I≲K ≋ I≲J >> J≲₁K) → (I≲K ≋ I≲J >> J≲₂K) → (J≲₁K ≋ J≲₂K)

data Mediated (I : Interp Σ X) (J K : Interp Σ (X ⊕ V ⊕ Y))
  (I≲J : I ≲ inode * J) (I≲K : I ≲ inode * K) : Set where
    _,_ : (J≲K : J ≲ K) → (I≲K ≋ I≲J >> J≲K) × (Unique I J K I≲J I≲K)
      → Mediated I J K I≲J I≲K

med-≲ : ∀ {I} {J K : Interp Σ (X ⊕ V ⊕ Y)} {I≲J I≲K} →
  (Mediated I J K I≲J I≲K) → (J ≲ K)
med-≲ (J≲K , I≲K≋I≲J≲K , J≲K-uniq) = J≲K

med-≋ : ∀ {I} {J K : Interp Σ (X ⊕ V ⊕ Y)} {I≲J I≲K} →
  (m : Mediated I J K I≲J I≲K) → (I≲K ≋ I≲J >> med-≲ m)
med-≋ (J≲K , I≲K≋I≲J≲K , J≲K-uniq) = I≲K≋I≲J≲K

med-uniq : ∀ {I} {J K : Interp Σ (X ⊕ V ⊕ Y)} {I≲J I≲K} →
  (Mediated I J K I≲J I≲K) → Unique I J K I≲J I≲K
med-uniq (J≲K , I≲K≋I≲J≲K , J≲K-uniq) = J≲K-uniq

Mediator : ∀ (I : Interp Σ X) → (J : Interp Σ (X ⊕ V ⊕ Y)) →
  (I ≲ inode * J) → (KB Σ (X ⊕ V ⊕ Y)) → Set₁
Mediator I J I≲J KB =
  ∀ K (I≲K : I ≲ inode * K) → (K ⊨ KB) → Mediated I J K I≲J I≲K

data Initial I KB (J : Interp Σ (X ⊕ V ⊕ Y)) : Set₁ where
  _,_ : ∀ (I≲J : I ≲ inode * J) → (J ⊨ KB) × (Mediator I J I≲J KB) →
    (J ∈ Initial I KB)

init-≲ : ∀ {I KB} {J : Interp Σ (X ⊕ V ⊕ Y)} →
  (J ∈ Initial I KB) → (I ≲ inode * J)
init-≲ (I≲J , J⊨KB , J-med) = I≲J

init-⊨ : ∀ {I KB} {J : Interp Σ (X ⊕ V ⊕ Y)} →
  (J ∈ Initial I KB) → (J ⊨ KB)
init-⊨ (I≲J , J⊨KB , J-med) = J⊨KB

init-med : ∀ {I KB} {J : Interp Σ (X ⊕ V ⊕ Y)} →
  (J-init : J ∈ Initial I KB) → Mediator I J (init-≲ J-init) KB
init-med (I≲J , J⊨KB , J-med) = J-med

-- I ⊕ KB₁ ⊨ KB₂ whenever the initial extension of I satisfying
-- KB₁ exists, and has exports satisfying KB₂.

data _⊕_⊨_ I (KB₁ : KB Σ (X ⊕ V ⊕ Y)) KB₂ : Set₁ where
    _,_ : ∀ J → ((J ∈ Initial I KB₁) × (enode * J ⊨ KB₂)) → (I ⊕ KB₁ ⊨ KB₂)

extension : ∀ {I KB₁ KB₂} → (I ⊕ KB₁ ⊨ KB₂) → (Interp Σ (X ⊕ V ⊕ Y))
extension (J , J-init , J⊨KB₂) = J

ext-init : ∀ {I} {KB₁ : KB Σ (X ⊕ V ⊕ Y)} {KB₂} →
  (I⊕KB₁⊨KB₂ : I ⊕ KB₁ ⊨ KB₂) → (extension I⊕KB₁⊨KB₂ ∈ Initial I KB₁)
ext-init (J , J-init , J⊨KB₂) = J-init

ext-⊨ : ∀ {I} {KB₁ : KB Σ (X ⊕ V ⊕ Y)} {KB₂} →
  (I⊕KB₁⊨KB₂ : I ⊕ KB₁ ⊨ KB₂) → (enode * (extension I⊕KB₁⊨KB₂) ⊨ KB₂)
ext-⊨ (J , J-init , J⊨KB₂) = J⊨KB₂

ext✓ : ∀ {I S T} {F : ABox Σ (X ⊕ V ⊕ Y)} {B} →
  (I⊕SF⊨TB : I ⊕ S , F ⊨ T , B) →
    (enode * (extension I⊕SF⊨TB) ⊨ (S , T) , B)
ext✓ I⊕SF⊨TB =
  ( ( proj₁ (init-⊨ (ext-init I⊕SF⊨TB))
    , proj₁ (ext-⊨ I⊕SF⊨TB) )
  , proj₂ (ext-⊨ I⊕SF⊨TB) )


module GUIgeneric.GUIFeaturesPart2 where

open import GUIgeneric.Prelude renaming (addButton to addButton')

open import GUIgeneric.GUIDefinitions renaming (add to add'; add' to add)
open import GUIgeneric.GUI
open import GUIgeneric.GUIExampleLib
open import StateSizedIO.GUI.WxGraphicsLibLevel3 renaming (addButton to addButton')
open import GUIgeneric.GUIFeatures
open import GUIgeneric.GUIExample using (propOneBtn; propTwoBtn ; black ; oneColumnLayout)

open import Data.Product
open import Data.Fin

data ReturnTypeₛ  (S : Set) : Set where
    noChange      : ReturnTypeₛ S
    changedState  : (snew : S) →  ReturnTypeₛ S

-- handler GUI interface with separte state (i.e. state is a separte set instead of GUI)
-- We might later separte State into a gui state and property state i.e. have
--  GuiState : Set
--  AttrState : GuiState → Set
--  s2GUI : GuiState → GUI
--  s2prop : (g : GuiState)(prop : AttrState g) → properties (s2GUI g)

handlerGUIInterfₛ  : (S : Set) (s2GUI : (s : S) → Frame)
                     → Interfaceˢ
handlerGUIInterfₛ S s2GUI .Stateˢ                        = S
handlerGUIInterfₛ S s2GUI .Methodˢ  s                    = methodsG (s2GUI s)
handlerGUIInterfₛ S s2GUI .Resultˢ  s m                  = ReturnTypeₛ S
handlerGUIInterfₛ S s2GUI .nextˢ s m noChange            = s
handlerGUIInterfₛ S s2GUI .nextˢ s m (changedState snew) = snew

handlerGUIObjectₛ : (i : Size)(S : Set) (s2GUI : (s : S) → Frame)(s : S) → Set
handlerGUIObjectₛ i S s2GUI s = IOObjectˢ- GuiLev1Interface (handlerGUIInterfₛ S s2GUI) i s

mutual
  hGuiObjₛ2ord : (i : Size)(S : Set)
                 (s2GUI : (s : S) → Frame)
                 (s2prop : (s : S) → properties (s2GUI s))
                 (obj :  (s : S) → handlerGUIObjectₛ i S s2GUI s)
                 (s : S)
                 → HandlerObject i (s2GUI s)
  method (hGuiObjₛ2ord i S s2GUI s2prop obj s) {j} m =
        hGuiObjₛ2ordaux ∞  j  S s2GUI s s2prop obj m (method (obj s) m )

  hGuiObjₛ2ordaux' : (j : Size)(j' : Size)(S : Set)
                  (s2GUI : (s : S) → Frame)(s : S)
                  (s2prop : (s : S) → properties (s2GUI s))
                  (obj :  (s : S) → handlerGUIObjectₛ j' S s2GUI s)
                  (m   : methodsG (s2GUI s))
                  (prog : IO' GuiLev1Interface j
                            (ReturnTypeₛ S))
                  → IO' GuiLev1Interface j
                         ( Σ[ r ∈ returnType (s2GUI s) ]
                            (IOObjectˢ GuiLev1Interface handlerInterface j'
                             (nextˢ handlerInterface (s2GUI s) m r)))
  hGuiObjₛ2ordaux' j j' S s2GUI s s2prop obj m (do' c f) = do' c (λ r → hGuiObjₛ2ordaux j j' S s2GUI s s2prop obj m  (f r) )
  hGuiObjₛ2ordaux' j j' S s2GUI s s2prop obj m (return' noChange ) = return' (noChange , hGuiObjₛ2ord j' S s2GUI s2prop obj s {-obj'-})
  hGuiObjₛ2ordaux' j j' S s2GUI s s2prop obj m (return' (changedState snew)) = return' (changedGUI (s2GUI snew) (s2prop snew) , hGuiObjₛ2ord j' S s2GUI s2prop obj snew {- obj'-})

  hGuiObjₛ2ordaux : (j : Size)(j' : Size)(S : Set)
                  (s2GUI : (s : S) → Frame)(s : S)
                  (s2prop : (s : S) → properties (s2GUI s))
                  (obj :  (s : S) → handlerGUIObjectₛ j' S s2GUI s)
                  (m   : methodsG (s2GUI s))
                  (prog : IO GuiLev1Interface j
                            (ReturnTypeₛ S))
                  → IO GuiLev1Interface j
                         ( Σ[ r ∈  returnType (s2GUI s) ]
                            (IOObjectˢ GuiLev1Interface handlerInterface j'
                             (nextˢ handlerInterface (s2GUI s) m r)))
  force (hGuiObjₛ2ordaux j j' S s2GUI s s2prop obj m pr) {j''} = hGuiObjₛ2ordaux' j'' j' S s2GUI s s2prop obj m (force pr)

{-   *** STATE MACHINES  **** -}

sMachineHdl : (S : Set)(s : S) (f  : Frame) → Set
sMachineHdl S s f =  (m : methodsG f)
              → IO GuiLev1Interface ∞ (ReturnTypeₛ S)

record SMachineState (S : Set)(s : S) : Set where
  field
    fSM     : Frame
    propSM  : properties fSM
    handlSM : sMachineHdl S s fSM

SMachine : Set → Set
SMachine S = (s : S) → SMachineState S s

open SMachineState public

SMachine2HandlerGuiObjectₛ : (S : Set)
                             (sm : SMachine S)
                             (s : S)
                             → handlerGUIObjectₛ ∞ S (λ s → sm s .fSM) s
method (SMachine2HandlerGuiObjectₛ S sm s) = sm s .handlSM

stateMachine2Obj : (S : Set)
                   (sm : SMachine S)
                   (s : S)
                   → HandlerObject ∞ (sm s .fSM)
stateMachine2Obj S sm = hGuiObjₛ2ord ∞ S
                        (λ s → sm s .fSM)
                        (λ s → sm s .propSM)
                        (λ s → SMachine2HandlerGuiObjectₛ S sm s)

stateMachine2GUI : (S : Set) (sm : SMachine S) (s : S) → GUI
stateMachine2GUI S sm s .defFrame = sm s .fSM
stateMachine2GUI S sm s .property = sm s .propSM
stateMachine2GUI S sm s .obj = stateMachine2Obj S sm s

compileSMachine :  {S : Set} (sm : SMachine S) (s : S)
                   → NativeIO Unit
compileSMachine {S} sm s =
         compileGUI (stateMachine2GUI S sm s)

{-  **************** FEATURE MACHINE **** -}

-- an example of a feature machine wihout additional states:

record FeatureVMVers1 : Set₁ where
  field
    Features  : Set
    State     : Set
    GUIF      : (f : Features) → SMachine State

record FMachine (BaseSt : Set) : Set₁ where
  field
     Features : Set
     AddStateF : Set
     GUIF      : (f : Features) → SMachine (BaseSt ⊎ AddStateF)
  State : Set
  State =  BaseSt ⊎ AddStateF

open FMachine public

featureVMFull2GUI : (BaseSt : Set)
                        (vm : FMachine BaseSt)
                        (f : vm .Features)
                        (s : State vm)
                        → GUI
featureVMFull2GUI BaseSt vm f s =
         stateMachine2GUI
              (BaseSt ⊎ vm .AddStateF)
              (vm .GUIF f)  s

featureVMFull2IOˢprog : {BaseSt : Set}
                        (vm : FMachine BaseSt)
                        (f : vm .Features)
                        (s : State vm) → IOˢ GuiLev3Interface ∞ (λ _ → Unit) []
featureVMFull2IOˢprog {BaseSt} vm f s = guiFull2IOˢprog (featureVMFull2GUI BaseSt vm f s)

compileFeatureVM : {BaseSt : Set}
                   (vm : FMachine BaseSt)
                   (f : vm .Features)
                   (s : State vm)
                    → NativeIO Unit
compileFeatureVM {BaseSt} vm f s = compileGUI (featureVMFull2GUI BaseSt vm f s)

{- methodsREduce creates from a method for the frame (addButon s g)
    a method for g -}

mutual
  methodsReduce : (g : Frame)(str : String)(m : MethodsStruct)
                  (u : methodsStruct2Method (addButton str g notOptimzed) m)
                  → methodsStruct2Method g m
  methodsReduce g str (fficom) (ffibtn , gcomp) = gcomp
  methodsReduce g str (⊥^) ()
  methodsReduce g str (m ⊎^unoptimized m₁) (inj₁ x) = inj₁ (methodsReduce g str m x)
  methodsReduce g str (m ⊎^unoptimized m₁) (inj₂ y) = inj₂ (methodsReduce g str m₁ y)
  methodsReduce g str (m ⊎^ m₁) x = methodsReduceaux g str m m₁
                                      (methodsUnivIsEmpty m)
                                      (methodsUnivIsEmpty m₁) x

  methodsReduceaux : (g : Frame)(str : String)(m : MethodsStruct)
                     (m₁ : MethodsStruct)
                     (s  : SemiDec (λ g' → methodsStruct2Method g'  m))
                     (s₁  : SemiDec (λ g' → methodsStruct2Method g' m₁))
                     (u : methodsStruct2Methodaux
                          (addButton str g notOptimzed) m m₁ s s₁)
                     → methodsStruct2Methodaux g  m m₁ s s₁
  methodsReduceaux g str m m₁ s (isEmpty s₁) u = methodsReduce g str m u
  methodsReduceaux g str m m₁ (isEmpty x) posNonEmpty u = methodsReduce g str m₁ u
  methodsReduceaux g str m m₁ posNonEmpty posNonEmpty (inj₁ x) = inj₁ (methodsReduce g str m x)
  methodsReduceaux g str m m₁ posNonEmpty posNonEmpty (inj₂ y) = inj₂ (methodsReduce g str m₁ y)

subMethodToFullMethod : (btnStr : String)
                        (fr     : Frame)
                        (m      : methodsStruct2Method (addButton btnStr fr notOptimzed)
                                   (methodStruct fr ))
                        → methodsG fr
subMethodToFullMethod btnStr fr m = methodsReduce fr btnStr (methodStruct fr ) m

simpleAttr1Btn : (btnStr : String) → properties (addButton btnStr create-frame notOptimzed)
simpleAttr1Btn btnStr = black , oneColumnLayout

simpleSMState : {S : Set}
                (btnStr : String)
                {start : S}
                (end : S)
                → SMachineState S start
simpleSMState btnStr end .fSM = addButton btnStr create-frame notOptimzed
simpleSMState btnStr end .propSM = simpleAttr1Btn btnStr
simpleSMState btnStr end .handlSM m .force  = return' (changedState end)

baseF : FMachine StateV
baseF .Features = ⊤
baseF .AddStateF = ⊥
baseF .GUIF f (inj₁ s0) = simpleSMState "1Euro" (inj₁ s1)
baseF .GUIF f (inj₁ s1) = simpleSMState "Get Change" (inj₁ s2)
baseF .GUIF f (inj₁ s2) = simpleSMState "Soda" (inj₁ s0)
baseF .GUIF f (inj₂ ())

addBtn2StateMachine : {S : Set}{s : S}(sm : SMachineState S s)
                      (btnStr : String)(end : S)
                      → SMachineState S s
addBtn2StateMachine sm btnStr end .fSM = addButton btnStr (sm .fSM) notOptimzed
addBtn2StateMachine sm btnStr end .propSM = black , sm .propSM
addBtn2StateMachine sm btnStr end .handlSM (inj₁ x) .force = return' (changedState end)
addBtn2StateMachine sm btnStr end .handlSM (inj₂ m) =
      sm .handlSM (subMethodToFullMethod btnStr (sm .fSM) m)

simpleCancel : FMachine StateV → FMachine StateV
simpleCancel vm .Features = vm .Features × FeatureCancel
simpleCancel vm .AddStateF  = vm .AddStateF
simpleCancel vm .GUIF (f , yesCancel) (inj₁ s1) =
          addBtn2StateMachine  (vm .GUIF f (inj₁ s1)) "Cancel"  (inj₁ s0)

simpleCancel vm .GUIF (f , _) s = vm .GUIF f s

simpleCancelBase : FMachine StateV
simpleCancelBase = simpleCancel baseF

main1 : NativeIO Unit
main1 = compileFeatureVM baseF _ (inj₁ s0) --

main : NativeIO Unit
main = compileFeatureVM simpleCancelBase (_ , yesCancel) (inj₁ s0) --


module Tactic.Reflection.Reright where
  open import Prelude hiding (abs)

  open import Container.Traversable

  open import Tactic.Reflection
  open import Tactic.Reflection.Match
  open import Tactic.Reflection.Replace
  open import Tactic.Reflection.Quote

  private
    {-# TERMINATING #-}
    reorderVars : List Nat → Term → Term
    reorderVars xs (var x args) = var (maybe x id (index xs x)) (fmap (reorderVars xs) <$> args)
    reorderVars xs (con c args) = con c ((fmap ∘ fmap) (reorderVars xs) args)
    reorderVars xs (def f args) = def f (fmap (reorderVars xs) <$> args)
    reorderVars xs (lam v t) = lam v (reorderVars (0 ∷ weaken 1 xs) <$> t)
    reorderVars xs (pat-lam cs args) = pat-lam (fmap (reorderVarsInClause xs) cs) ((fmap ∘ fmap) (reorderVars xs) args) where
      reorderVarsInClause : List Nat → Clause → Clause -- TODO reorder patterns?
      reorderVarsInClause xs (clause ps t) = (clause ps (reorderVars xs t))
      reorderVarsInClause xs (absurd-clause ps) = (absurd-clause ps)
    reorderVars xs (pi a b) = pi (reorderVars xs <$> a) (reorderVars (0 ∷ weaken 1 xs) <$> b)
    reorderVars xs (agda-sort (set t)) = agda-sort (set (reorderVars xs t))
    reorderVars xs (agda-sort (lit n)) = agda-sort (lit n)
    reorderVars xs (agda-sort unknown) = agda-sort unknown
    reorderVars xs (lit l) = lit l
    reorderVars xs (meta x args) = meta x $ (fmap ∘ fmap) (reorderVars xs) args
    reorderVars xs unknown = unknown

    {-# TERMINATING #-}
    freeDependencies : List (Arg Type) → Type → Maybe VarSet
    freeDependencies Γ x = foldr _∪_ (freeVars x) <$> mapM go (freeVars x) where
      _∪_ : VarSet → VarSet → VarSet -- REFACTOR this was stolen from Tactic.Reflection.Free
      []       ∪ ys = ys
      xs       ∪ [] = xs
      (x ∷ xs) ∪ (y ∷ ys) with compare x y
      ... | (less    _) = x ∷ (xs ∪ (y ∷ ys))
      ... | (equal   _) = x ∷ (xs ∪ ys)
      ... | (greater _) = y ∷ ((x ∷ xs) ∪ ys)

      go : Nat → Maybe VarSet
      go v = weaken (suc v) $ join $ freeDependencies (drop (suc v) Γ) <$> (unArg <$> index Γ v)

    .test-freeDependencies₁ : freeDependencies [] unknown ≡ just []
    test-freeDependencies₁ = refl

    .test-freeDependencies₂ : freeDependencies (vArg (var₀ 0) ∷ vArg unknown ∷ []) (var₀ 0) ≡ just (0 ∷ 1 ∷ [])
    test-freeDependencies₂ = refl

    .test-freeDependencies₃ : freeDependencies (vArg (var₀ 0) ∷ vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₀ 0) ≡ just (0 ∷ 1 ∷ 3 ∷ [])
    test-freeDependencies₃ = refl

    .test-freeDependencies₄ : freeDependencies (vArg (var₀ 0) ∷ vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₀ 1) ≡ just (1 ∷ 3 ∷ [])
    test-freeDependencies₄ = refl

    .test-freeDependencies₅ : freeDependencies (vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₀ 0) ≡ just (0 ∷ 2 ∷ [])
    test-freeDependencies₅ = refl

    .test-freeDependencies₆ : freeDependencies (vArg (var₀ 0) ∷ vArg (var₀ 1) ∷ vArg unknown ∷ vArg unknown ∷ []) (var₁ 0 (var₀ 1)) ≡ just (0 ∷ 1 ∷ 3 ∷ [])
    test-freeDependencies₆ = refl

    record Request : Set where
      field
        l≡r : Term
        A : Type
        L R : Type
        Γᶜ : List (Arg Type)
        𝐺 : Type

      [iᶜ∣iᶜ∈FVᴬ] : VarSet
      [iᶜ∣iᶜ∈FVᴬ] = maybe [] id $ freeDependencies Γᶜ A -- TODO this is a hack; I don't expect freeDependencies will return 'nothing', but if it does, I hope(!) the rest of the computation will fail

      [iᶜ∣iᶜ∉FVᴬ] : VarSet
      [iᶜ∣iᶜ∉FVᴬ] = filter (not ∘ flip elem [iᶜ∣iᶜ∈FVᴬ]) (from 0 for (length Γᶜ))

      record γᶜ' : Set where
        field
          iᶜ : Nat
          γᶜᵢ : Arg Type
          iᶜ∈FVᴬ : Bool
          iʷ : Nat
          γᶜᵢ∈Γʳ : Bool

        gᶜᵢ : Type
        gᶜᵢ = unArg γᶜᵢ

      Γᶜ' : List γᶜ'
      Γᶜ' = go 0 (length Γᶜ) Γᶜ where
        go : Nat → Nat → List (Arg Type) → List γᶜ'
        go iᶜ 0 _ = []
        go iᶜ _ [] = []
        go iᶜ (suc n) (γᶜᵢ ∷ Γᶜ) = γᶜᵢ' ∷ go (suc iᶜ) n (weaken 1 Γᶜ) where
          γᶜᵢ' = record
            { iᶜ = iᶜ
            ; γᶜᵢ = γᶜᵢ
            ; iᶜ∈FVᴬ = elem iᶜ [iᶜ∣iᶜ∈FVᴬ]
            ; iʷ = if elem iᶜ [iᶜ∣iᶜ∉FVᴬ] then (length (filter (_<? iᶜ) [iᶜ∣iᶜ∉FVᴬ])) else (length [iᶜ∣iᶜ∉FVᴬ] + (length (filter (_≤? iᶜ) [iᶜ∣iᶜ∈FVᴬ])))
            ; γᶜᵢ∈Γʳ = let gᶜᵢ = unArg γᶜᵢ in (isNo $ weaken 1 gᶜᵢ == weaken 1 gᶜᵢ r[ unknown / L ]) && (isNo $ l≡r == var₀ iᶜ)
            }

      [iʷ∣γᶜᵢ∈Γʳ] : VarSet
      [iʷ∣γᶜᵢ∈Γʳ] = iʷ <$> filter γᶜᵢ∈Γʳ Γᶜ' where open γᶜ'

      [iʷ] : List Nat
      [iʷ] = iʷ <$> Γᶜ' where open γᶜ'

      subsetList : {A : Set} → List A → List Nat → Maybe (List A)
      subsetList xs is = traverse (index xs) is

      module _ where
        private
          Γʷ/ᶜ : Maybe (List (Arg Type))
          Γʷ/ᶜ = go [iʷ] Γᶜ where
            go : List Nat → List (Arg Type) → Maybe (List (Arg Type))
            go _ [] = just []
            go [] _ = nothing
            go (iʷ ∷ [iʷ]) (γᶜᵢ ∷ Γᶜ) = _∷_ <$> (strengthen (suc iʷ) $ reorderVars [iʷ] <$> γᶜᵢ) <*> (go [iʷ] Γᶜ)

        Γʷ/ᴬ = join $ subsetList <$> Γʷ/ᶜ <*> pure [iᶜ∣iᶜ∈FVᴬ]
        Γʷ/⁻ᴬ = join $ subsetList <$> Γʷ/ᶜ <*> pure [iᶜ∣iᶜ∉FVᴬ]

      module _ where
        private
          Lʷ = reorderVars [iʷ] L

        Γʷ = caseF Γʷ' of _R[ var₀ (length [iᶜ∣iᶜ∉FVᴬ]) / Lʷ ] where
          Γʷ' : Maybe (List (Arg Type))
          Γʷ' = _++_ <$> Γʷ/⁻ᴬ <*> (_∷_ <$> (strengthen (length [iᶜ∣iᶜ∉FVᴬ] + 1) $ hArg (reorderVars [iʷ] A)) <*> Γʷ/ᴬ) where

        𝐺ʷ = reorderVars [iʷ] 𝐺 r[ var₀ (length [iᶜ∣iᶜ∉FVᴬ]) / Lʷ ]

      module _ where
        private
          Rʷ = reorderVars [iʷ] R

        gʳ : Maybe Type
        gʳ = join $ go <$> gʳ' <*> pure [iʷ∣γᶜᵢ∈Γʳ] <*> pure 𝐺ʷʳ where
          go : List (Arg Type) → List Nat → Type → Maybe Type
          go [] [] 𝐺 = just 𝐺
          go (γʷ ∷ Γʷ) (iʷ ∷ iʷs) 𝐺 = go Γʷ iʷs $ pi (weaken (1 + iʷ) γʷ) $ abs "_" $ weaken 1 𝐺 r[ var₀ 0 / var₀ $ weaken 1 iʷ ]
          go _ _ _ = nothing

          gʳ' : Maybe (List (Arg Type))
          gʳ' = join $ subsetList <$> (caseF Γʷ of _R[ Rʷ / var₀ (length [iᶜ∣iᶜ∉FVᴬ]) ]) <*> pure [iʷ∣γᶜᵢ∈Γʳ]

          𝐺ʷʳ = 𝐺ʷ r[ Rʷ / var₀ (length [iᶜ∣iᶜ∉FVᴬ]) ]

        helper-type : Maybe Type
        helper-type = telPi <$> (_++_ <$> (reverse <$> Γʷ) <*> (_∷_ <$> (pure $ vArg (def₂ (quote _≡_) (var₀ (length [iᶜ∣iᶜ∉FVᴬ])) Rʷ)) <*> ([_] ∘ vArg <$> (weaken 1 <$> gʳ)))) <*> pure (weaken 2 𝐺ʷ)

      make-vars-from-args : List Nat → List (Arg Type) → Maybe (List (Arg Type))
      make-vars-from-args [] [] = pure []
      make-vars-from-args (i ∷ is) (x ∷ xs) = _∷_ <$> pure (var₀ i <$ x) <*> make-vars-from-args is xs
      make-vars-from-args _ _ = nothing

      defineHelper : Name → TC ⊤
      defineHelper n =
        maybe (typeError ( strErr "error constructing helper function type, patterns, or term" ∷
                           strErr "\nhelper-type:" ∷ termErr (maybe unknown id helper-type) ∷
                           strErr "\n`helper-type:" ∷ termErr (` helper-type) ∷
                           strErr "\nhelper-patterns:" ∷ termErr (` helper-patterns) ∷
                           strErr "\nhelper-term:" ∷ termErr (maybe unknown id helper-term) ∷
                           strErr "\ngʳ:" ∷ termErr (` gʳ) ∷
                           strErr "\nΓʷ:" ∷ termErr (` Γʷ) ∷
                           strErr "\n𝐺ʷ:" ∷ termErr (` 𝐺ʷ) ∷
                           strErr "\nl≡r:" ∷ termErr (` l≡r) ∷
                           strErr "\nA:" ∷ termErr (` A) ∷
                           strErr "\nL:" ∷ termErr (` L) ∷
                           strErr "\nR:" ∷ termErr (` R) ∷
                           strErr "\nΓᶜ:" ∷ termErr (` Γᶜ) ∷
                           strErr "\n𝐺:" ∷ termErr (` 𝐺) ∷
                           strErr "\nΓʷ/ᴬ" ∷ termErr (` Γʷ/ᴬ) ∷
                           strErr "\nΓʷ/⁻ᴬ" ∷ termErr (` Γʷ/⁻ᴬ) ∷
                           strErr "\n[iᶜ∣iᶜ∈FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∈FVᴬ]) ∷
                           strErr "\n[iᶜ∣iᶜ∉FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∉FVᴬ]) ∷
                           strErr "\n[iʷ]" ∷ termErr (` [iʷ]) ∷
                           [] ))
              (λ {(helper-type , helper-patterns , helper-term) →
                catchTC
                  (define (vArg n) helper-type [ clause helper-patterns helper-term ])
                  (typeError ( strErr "error defining helper function" ∷
                               strErr "\nhelper-type:" ∷ termErr helper-type ∷
                               strErr "\n`helper-type:" ∷ termErr (` helper-type) ∷
                               strErr "\nhelper-patterns:" ∷ termErr (` helper-patterns) ∷
                               strErr "\nhelper-term:" ∷ termErr helper-term ∷
                               strErr "\n`helper-term:" ∷ termErr (` helper-term) ∷
                               strErr "\ngʳ:" ∷ termErr (` gʳ) ∷
                               strErr "\nΓʷ:" ∷ termErr (` Γʷ) ∷
                               strErr "\n𝐺ʷ:" ∷ termErr (` 𝐺ʷ) ∷
                               strErr "\nl≡r:" ∷ termErr (` l≡r) ∷
                               strErr "\nA:" ∷ termErr (` A) ∷
                               strErr "\nL:" ∷ termErr (` L) ∷
                               strErr "\nR:" ∷ termErr (` R) ∷
                               strErr "\nΓᶜ:" ∷ termErr (` Γᶜ) ∷
                               strErr "\n𝐺:" ∷ termErr (` 𝐺) ∷
                               strErr "\nΓʷ/ᴬ" ∷ termErr (` Γʷ/ᴬ) ∷
                               strErr "\nΓʷ/⁻ᴬ" ∷ termErr (` Γʷ/⁻ᴬ) ∷
                               strErr "\n[iᶜ∣iᶜ∈FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∈FVᴬ]) ∷
                               strErr "\n[iᶜ∣iᶜ∉FVᴬ]" ∷ termErr (` [iᶜ∣iᶜ∉FVᴬ]) ∷
                               strErr "\n[iʷ]" ∷ termErr (` [iʷ]) ∷
                               [] ))
                  })
              (_,_ <$> helper-type <*> (_,_ <$> helper-patterns <*> helper-term))
        where

        helper-patterns : Maybe (List (Arg Pattern))
        helper-patterns = (λ pa w p-a pr → pa ++ w ∷ (p-a ++ pr)) <$> (telePat ∘ reverse <$> Γʷ/ᴬ) <*> just (hArg dot) <*> (telePat ∘ reverse <$> Γʷ/⁻ᴬ) <*> pure (vArg (con₀ (quote refl)) ∷ [ vArg (var "_") ])

        helper-term : Maybe Term
        helper-term = do
          γʷs ← join $ subsetList <$> Γʷ <*> pure [iʷ∣γᶜᵢ∈Γʳ]
          iʷs ← make-vars-from-args [iʷ∣γᶜᵢ∈Γʳ] γʷs
          pure (var 0 (reverse (weaken 1 iʷs)))

      callHelper : Name → Tactic
      callHelper n hole =
        maybe (typeError [ strErr "error constructing helper call" ])
              (unify hole)
              $ helper-call n
        where

        helper-call : Name → Maybe Term
        helper-call n = def n <$> (reverse <$> (_∷_ <$> pure (vArg l≡r) <*> Γʰ)) where
          Γʰ : Maybe $ List $ Arg Term
          Γʰ = (λ xs → take (length [iᶜ∣iᶜ∉FVᴬ]) xs ++ hArg unknown ∷ drop (length [iᶜ∣iᶜ∉FVᴬ]) xs) <$> (join $ make-vars-from-args <$> pure ([iᶜ∣iᶜ∉FVᴬ] ++ [iᶜ∣iᶜ∈FVᴬ]) <*> Γʰ') where
            Γʰ' : Maybe (List (Arg Type))
            Γʰ' = _++_ <$> subsetList Γᶜ [iᶜ∣iᶜ∉FVᴬ] <*> subsetList Γᶜ [iᶜ∣iᶜ∈FVᴬ]

    inferGoal : Term → TC Type
    inferGoal hole = unPi =<< forceFun =<< inferType hole where
      unPi : Type → TC Type
      unPi (pi _ (abs _ (meta x _))) = blockOnMeta! x
      unPi (pi _ (abs _ b)) = maybe (typeError (strErr "error strengthening" ∷ termErr b ∷ [])) pure $ strengthen 1 b
      unPi x = typeError (strErr "goal is not a pi type" ∷ termErr x ∷ [])

    getRequest : Term → Term → TC Request
    getRequest l≡r hole = do
      L≡R ← inferType l≡r
      L≡R-matched ← maybe (typeError (strErr "not an equality" ∷ termErr l≡r ∷ termErr L≡R ∷ [])) pure $
        match 3 (def (quote _≡_) (hArg unknown ∷ (hArg (var₀ 0)) ∷ (vArg (var₀ 1)) ∷ (vArg (var₀ 2)) ∷ [])) L≡R
      𝐺 ← inferGoal hole
      Γᶜ ← getContext
      case L≡R-matched of λ { (A ∷ L ∷ R ∷ []) →
        pure $ record { l≡r = l≡r ; A = A ; L = L ; R = R ; Γᶜ = Γᶜ ; 𝐺 = 𝐺 } }

  macro
    reright : Term → Tactic
    reright l≡r hole = do
      q ← getRequest l≡r hole
      n ← freshName "reright"
      let open Request q
      defineHelper n
      callHelper n hole


module Unsolved-meta-in-postulate where

postulate P : _


module correct where
open import cfg
open import jarsec using (Parser ; parse ; run-parser ; partial-parse ; _>>=_ ; _>>_ ; _<*>_)

open import Data.Bool
open import Data.List hiding (lookup)
open import Data.Fin hiding (_+_)
open import Data.Char
open import Agda.Builtin.Char renaming ( primCharEquality to charEq )
open import Data.Nat
open import Relation.Binary.PropositionalEquality using (_≡_ ; _≢_ ; refl)
open import Relation.Unary
open import Data.Maybe hiding (Any ; All)
open import Data.Sum hiding (map)
open import Data.String hiding (length ; _++_) renaming (primStringToList to 𝕊→𝕃 ; primStringFromList to 𝕃→𝕊)
open import Data.Product hiding (map)
open import Agda.Builtin.Unit
open import Data.List.All
open import Level

postulate
  sym : ∀ {A : Set} {x y : A} → x ≡ y → y ≡ x
  head-from-≡ : ∀ {A : Set} {x y : A} {xs ys : List A} → (x List.∷ xs) ≡ (y ∷ ys) → x ≡ y
  tail-from-≡ : ∀ {A : Set} {x y : A} {xs ys : List A} → (x List.∷ xs) ≡ (y ∷ ys) → xs ≡ ys

  ++-runit : ∀ {A : Set} (m : List A) → m ++ [] ≡ m
  ++-assoc : ∀ {A : Set} (m n p : List A) → (m ++ n) ++ p ≡ m ++ (n ++ p)

  charEq-T : ∀ x c → (charEq x c) ≡ true → x ≡ c
  charEq-F : ∀ x c → (charEq x c) ≡ false → x ≢ c

correct : ∀ (cfg : Cfg 0) (cs : List Char)
  → let rs = jarsec.parse (interp cfg) cs in
    All (λ r → ((proj₁ r) ∈[ cfg ]) × (proj₁ r) ++ (proj₂ r) ≡ cs) rs

correct emp cs = []
correct eps cs = (eps , refl) ∷ []
correct (lit x) [] = []
correct (lit x) (c ∷ cs) with charEq x c | charEq-T x c | charEq-F x c
... | true | b | d rewrite b refl = (lit c , refl) ∷ []
... | false | b | d = []
correct (var ()) cs
correct (seq cfg₁ cfg₂) cs = {! correct-seq₁ (parse (interp cfg₁) cs) (correct cfg₁ cs)  !}
correct (seq cfg₁ cfg₂) cs with (parse (interp cfg₁) cs) | correct cfg₁ cs
correct (seq cfg₁ cfg₂) cs | [] | [] = []
correct (seq cfg₁ cfg₂) cs | r₁ ∷ rs₁ | a₁ ∷ all₁ with parse (interp cfg₂) (proj₂ r₁) | correct cfg₂ (proj₂ r₁)
correct (seq cfg₁ cfg₂) cs | r₁ ∷ rs₁ | a₁ ∷ all₁ | [] | [] = ?
correct (seq cfg₁ cfg₂) cs | r₁ ∷ rs₁ | a₁ ∷ all₁ | r₂ ∷ rs₂ | a₂ ∷ all₂

  = strengthen-to-seq r₁ a₁ r₂ a₂ ∷ correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ rs₂ all₂
  where
  Result : Set
  Result = List Char × List Char
  strengthen-to-seq :
    ∀ (r₁ : Result)
    → (a₁ : proj₁ r₁ ∈[ cfg₁ ] × proj₁ r₁ ++ proj₂ r₁ ≡ cs)
    → (r₂ : Result)
    → (a₂ : proj₁ r₂ ∈[ cfg₂ ] × proj₁ r₂ ++ proj₂ r₂ ≡ proj₂ r₁)
    → (proj₁ r₁ ++ proj₁ r₂) ∈[ seq cfg₁ cfg₂ ] × (proj₁ r₁ ++ proj₁ r₂) ++ proj₂ r₂ ≡ cs
  strengthen-to-seq r₁ a₁ r₂ a₂
    rewrite ++-assoc (proj₁ r₁)  (proj₁ r₂) (proj₂ r₂)
    | proj₂ a₂
    | proj₂ a₁
    = (seq (proj₁ a₁) (proj₁ a₂)) , refl

  -- correct-seq₁ :
  --   ∀ (rs₁ : List Result)
  --   → (all₁ : All (λ r → (proj₁ r ∈[ cfg₁ ]) × proj₁ r ++ proj₂ r ≡ cs) rs₁)
  --   → All (λ r → (proj₁ r ∈[ seq cfg₁ cfg₂ ]) × proj₁ r ++ proj₂ r ≡ cs)
  --     (parse (interp cfg₁ >>= (λ x → interp cfg₂ >>= (λ y →
  --       Parser.mk-parser (λ str → (x ++ y , str) ∷ [])))) cs)
  -- correct-seq₁ [] [] = {! []  !}
  -- correct-seq₁ (r₁ ∷ rs₁) (a₁ ∷ all₁) = {!   !}

  correct-seq₂ :
    ∀ (cfg₁ cfg₂ : Cfg 0) (cs : List Char)
    → (r₁ : Result)
    → (rs₁ : List Result)
    → (a₁ : Σ (proj₁ r₁ ∈[ cfg₁ ]) (λ x → proj₁ r₁ ++ proj₂ r₁ ≡ cs))
    → (all₁ : All (λ r → Σ (proj₁ r ∈[ cfg₁ ]) (λ x → proj₁ r ++ proj₂ r ≡ cs)) rs₁)
    → All (λ r → (proj₁ r ∈[ seq cfg₁ cfg₂ ]) × proj₁ r ++ proj₂ r ≡ cs)
      (concatMap
       (λ x →
          concatMap (λ x₁ → (proj₁ x ++ proj₁ x₁ , proj₂ x₁) ∷ [])
          (parse (interp cfg₂) (proj₂ x)))
       rs₁)
  correct-seq₂ cfg₁ cfg₂ cs r₁ [] a₁ [] = []
  correct-seq₂ cfg₁ cfg₂ cs r₁ (x ∷ rs₁) a₁ (px ∷ all₁) = ?

  correct-seq₁ :
    ∀ (cfg₁ cfg₂ : Cfg 0) (cs : List Char)
    → (r₁ : Result)
    → (rs₁ : List Result)
    → (a₁ : Σ (proj₁ r₁ ∈[ cfg₁ ]) (λ x → proj₁ r₁ ++ proj₂ r₁ ≡ cs))
    → (all₁ : All (λ r → Σ (proj₁ r ∈[ cfg₁ ]) (λ x → proj₁ r ++ proj₂ r ≡ cs)) rs₁)
    → (rs₂ : List Result)
    → (all₂ : All (λ r → Σ (proj₁ r ∈[ cfg₂ ]) (λ x → proj₁ r ++ proj₂ r ≡ proj₂ r₁)) rs₂)
    → All (λ r → proj₁ r ∈[ seq cfg₁ cfg₂ ] × proj₁ r ++ proj₂ r ≡ cs)
      (foldr _++_ []
        (Data.List.map (λ x → (proj₁ r₁ ++ proj₁ x , proj₂ x) ∷ []) rs₂)
        ++
        (concatMap (λ x →
          (concatMap (λ x₁ → (proj₁ x ++ proj₁ x₁ , proj₂ x₁) ∷ [])
            (parse (interp cfg₂) (proj₂ x))))
        rs₁))

  correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ [] [] = correct-seq₂ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁
  correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ (r₂ ∷ rs₂) (a₂ ∷ all₂)
    = ((seq (proj₁ a₁) (proj₁ a₂)) , fact) ∷ correct-seq₁ cfg₁ cfg₂ cs r₁ rs₁ a₁ all₁ rs₂ all₂
      where
      fact : (proj₁ r₁ ++ proj₁ r₂) ++ proj₂ r₂ ≡ cs
      fact rewrite ++-assoc (proj₁ r₁) (proj₁ r₂) (proj₂ r₂)
        | proj₂ a₂
        | proj₂ a₁
        = refl

correct (alt cfg₁ cfg₂) cs with (Parser.parse (interp (seq cfg₁ cfg₂)) cs)
... | rs =
  let all₁ = correct cfg₁ cs
      all₂ = correct cfg₂ cs

      weak-all₁ : All (λ r → proj₁ r ∈[ alt cfg₁ cfg₂ ] × proj₁ r ++ proj₂ r ≡ cs) (Parser.parse (interp cfg₁) cs)
      weak-all₁ = Data.List.All.map
        (λ r → ((weaken-to-alt {cfg₁ = cfg₁} {cfg₂ = cfg₂} (inj₁ (proj₁ r))) , (proj₂ r)))
        all₁

      weak-all₂ : All (λ r → proj₁ r ∈[ alt cfg₁ cfg₂ ] × proj₁ r ++ proj₂ r ≡ cs) (Parser.parse (interp cfg₂) cs)
      weak-all₂ = Data.List.All.map
        (λ r → (weaken-to-alt {cfg₁ = cfg₁} {cfg₂ = cfg₂} (inj₂ (proj₁ r))) , (proj₂ r))
        all₂

  in all++ weak-all₁ weak-all₂

  where
    all++ : ∀ {p} {A : Set} {P : Pred A p} {xs ys : List A}
      → All P xs → All P ys → All P (xs ++ ys)
    all++ [] [] = []
    all++ [] (py ∷ all₂) = py ∷ (all++ [] all₂)
    all++ (px ∷ all₁) all₂ = px ∷ (all++ all₁ all₂)

    weaken-to-alt : ∀ {r} {cfg₁ cfg₂ : Cfg 0}
      → (r ∈[ cfg₁ ]) ⊎ (r ∈[ cfg₂ ]) → r ∈[ alt cfg₁ cfg₂ ]
    weaken-to-alt (inj₁ e) = alt₁ e
    weaken-to-alt (inj₂ e) = alt₂ e

correct (many cfg) cs = ?

correct (fix cfg) cs = ?


module New.LangOps where

open import New.Lang
open import New.Changes
open import New.LangChanges

oplusτo : ∀ {Γ} τ → Term Γ (τ ⇒ Δt τ ⇒ τ)
ominusτo : ∀ {Γ} τ → Term Γ (τ ⇒ τ ⇒ Δt τ)

onilτo : ∀ {Γ} τ → Term Γ (τ ⇒ Δt τ)
onilτo τ = abs (app₂ (ominusτo τ) (var this) (var this))

-- Do NOT try to read this, such terms are write-only. But the behavior is
-- specified to be oplusτ-equiv and ominusτ-equiv.
oplusτo (σ ⇒ τ) = abs (abs (abs
  (app₂ (oplusτo τ)
    (app (var (that (that this))) (var this))
    (app₂ (var (that this)) (var this) (app (onilτo σ) (var this))))))
oplusτo int = const plus
oplusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (oplusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (oplusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
oplusτo (sum σ τ) = abs (abs (app₃ (const match) (var (that this))
  (abs (app₃ (const match) (var (that this))
    (abs (app₃ (const match) (var this)
      (abs (app (const linj) (app₂ (oplusτo σ) (var (that (that this))) (var this))))
      (abs (app (const linj) (var (that (that this)))))))
    (abs (var this))))
  (abs (app₃ (const match) (var (that this))
    (abs (app₃ (const match) (var this)
      (abs (app (const rinj) (var (that (that this)))))
      (abs (app (const rinj) (app₂ (oplusτo τ) (var (that (that this))) (var this))))))
    (abs (var this))))))

ominusτo (σ ⇒ τ) = abs (abs (abs (abs (app₂ (ominusτo τ)
  (app (var (that (that (that this)))) (app₂ (oplusτo σ) (var (that this)) (var this)))
  (app (var (that (that this))) (var (that this)))))))
ominusτo int = const minus
ominusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (ominusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (ominusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
ominusτo (sum σ τ) = abs (abs (app₃ (const match) (var (that this))
  (abs (app₃ (const match) (var (that this))
    (abs (app (const linj) (app (const linj) (app₂ (ominusτo σ) (var (that this)) (var this)))))
    (abs (app (const rinj) (var (that (that (that this))))))))
  (abs (app₃ (const match) (var (that this))
    (abs (app (const rinj) (var (that (that (that this))))))
    (abs (app (const linj) (app (const rinj) (app₂ (ominusτo τ) (var (that this)) (var this)))))))))

oplusτ-equiv : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ a da → ⟦ oplusτo τ ⟧Term ρ a da ≡ a ⊕ da
ominusτ-equiv : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ b a → ⟦ ominusτo τ ⟧Term ρ b a ≡ b ⊝ a

oplusτ-equiv-ext : ∀ τ Γ → ⟦ oplusτo {Γ} τ ⟧Term ≡ λ ρ → _⊕_
oplusτ-equiv-ext τ _ = ext³ (λ ρ a da → oplusτ-equiv _ ρ τ a da)
ominusτ-equiv-ext : ∀ τ Γ → ⟦ ominusτo {Γ} τ ⟧Term ≡ λ ρ → _⊝_
ominusτ-equiv-ext τ _ = ext³ (λ ρ a da → ominusτ-equiv _ ρ τ a da)

oplusτ-equiv Γ ρ (σ ⇒ τ) f df = ext (λ a → lemma a)
  where
    module _ (a : ⟦ σ ⟧Type) where
      ρ′ = a • df • f • ρ
      ρ′′ = a • ρ′
      lemma : ⟦ oplusτo τ ⟧Term ρ′ (f a)
         (df a (⟦ ominusτo σ ⟧Term ρ′′ a a))
         ≡ f a ⊕ df a (nil a)
      lemma
        rewrite ominusτ-equiv _ ρ′′ σ a a
        | oplusτ-equiv _ ρ′ τ (f a) (df a (nil a))
        = refl
oplusτ-equiv Γ ρ int a da = refl
oplusτ-equiv Γ ρ (pair σ τ) (a , b) (da , db)
  rewrite oplusτ-equiv _ ((da , db) • (a , b) • ρ) σ a da
  | oplusτ-equiv _ ((da , db) • (a , b) • ρ) τ b db
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ (inj₁ dx))
  rewrite oplusτ-equiv-ext σ (Δt σ • sum (Δt σ) (Δt τ) • σ • Δt (sum σ τ) • sum σ τ • Γ)
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ (inj₂ dy)) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₂ y) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ (inj₁ dx)) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ (inj₂ dy))
  rewrite oplusτ-equiv-ext τ (Δt τ • sum (Δt σ) (Δt τ) • τ • Δt (sum σ τ) • sum σ τ • Γ)
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₂ y₁) = refl

ominusτ-equiv Γ ρ (σ ⇒ τ) g f = ext (λ a → ext (lemma a))
  where
    module _ (a : ⟦ σ ⟧Type) (da : Chτ σ) where
      ρ′ = da • a • f • g • ρ
      lemma : ⟦ ominusτo τ ⟧Term (da • a • f • g • ρ)
        (g (⟦ oplusτo σ ⟧Term (da • a • f • g • ρ) a da)) (f a)
        ≡ g (a ⊕ da) ⊝ f a
      lemma
        rewrite oplusτ-equiv _ ρ′ σ a da
        | ominusτ-equiv _ ρ′ τ (g (a ⊕ da)) (f a) = refl
ominusτ-equiv Γ ρ int b a = refl
ominusτ-equiv Γ ρ (pair σ τ) (a2 , b2) (a1 , b1)
  rewrite ominusτ-equiv _ ((a1 , b1) • (a2 , b2) • ρ) σ a2 a1
  | ominusτ-equiv _ ((a1 , b1) • (a2 , b2) • ρ) τ b2 b1
  = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ x₁)
  rewrite ominusτ-equiv-ext σ (σ • σ • sum σ τ • sum σ τ • Γ)
  = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₂ y) = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ x) = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₂ y₁)
  rewrite ominusτ-equiv-ext τ (τ • τ • sum σ τ • sum σ τ • Γ)
  = refl


module subst where

open import constants
open import cedille-types
open import ctxt-types
open import free-vars
open import rename
open import general-util
open import syntax-util
open import type-util

substh-ret-t : Set → Set
substh-ret-t T = ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → T → T

{-# TERMINATING #-}
substh : ∀ {ed} → substh-ret-t ⟦ ed ⟧
substh-arg : substh-ret-t arg
substh-args : substh-ret-t args
substh-params' : ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → params → params × ctxt × renamectxt × trie (Σi exprd ⟦_⟧)
substh-indices : substh-ret-t indices
substh-params : substh-ret-t params
substh-case : substh-ret-t case
substh-cases : substh-ret-t cases
substh-case-args : ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → case-args → case-args × renamectxt × ctxt × trie (Σi exprd ⟦_⟧)
substh-datatype-info : substh-ret-t datatype-info

subst-rename-var-if : ∀ {ed} → ctxt → renamectxt → var → trie (Σi exprd ⟦_⟧) → ⟦ ed ⟧ → var
subst-rename-var-if Γ ρ ignored-var σ t = if is-free-in ignored-var t then fresh-h (λ s → ctxt-binds-var Γ s || trie-contains σ s || renamectxt-in-field ρ s) "x" else ignored-var
subst-rename-var-if Γ ρ x σ _ =
  {- rename bound variable x iff it is one of the vars being substituted for,
     or if x occurs free in one of the terms we are substituting for vars,
     or if it is the renamed version of any variable -}
  if trie-contains σ x {-|| trie-any (λ {(,_ {ed} t) → is-free-in x t}) σ-} || renamectxt-in-range ρ x || ctxt-binds-var Γ x then
    fresh-h (λ s → ctxt-binds-var Γ s || trie-contains σ s || renamectxt-in-field ρ s) x
  else
    x

substh {TERM} Γ ρ σ (App t t') = App (substh Γ ρ σ t) (substh Γ ρ σ t')
substh {TERM} Γ ρ σ (AppE t tT) = AppE (substh Γ ρ σ t) (substh Γ ρ σ -tT tT)
substh {TERM} Γ ρ σ (Lam me x oc t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    Lam me x' (substh Γ ρ σ -tk_ <$> oc)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TERM} Γ ρ σ (LetTm me x T t t') =
  let x' = subst-rename-var-if Γ ρ x σ t' in
    LetTm me x' (substh Γ ρ σ <$> T) (substh Γ ρ σ t)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t')
substh {TERM} Γ ρ σ (LetTp x k T t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    LetTp x' (substh Γ ρ σ k) (substh Γ ρ σ T)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TERM} Γ ρ σ (Var x) =
 let x' = renamectxt-rep ρ x in
   case trie-lookup σ x' of λ where
     (just (,_ {TERM} t)) → t
     _ → Var x'
substh {TERM} Γ ρ σ (Hole pi) = Hole pi -- Retain position, so jumping to hole works
substh {TERM} Γ ρ σ (Beta t t') = Beta (substh Γ ρ σ t) (substh Γ ρ σ t')
substh {TERM} Γ ρ σ (IotaPair t₁ t₂ x T) =
  let x' = subst-rename-var-if Γ ρ x σ T in
  IotaPair (substh Γ ρ σ t₁) (substh Γ ρ σ t₂) x' (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T)
substh {TERM} Γ ρ σ (IotaProj t n) = IotaProj (substh Γ ρ σ t) n
substh {TERM} Γ ρ σ (Sigma t) = Sigma (substh Γ ρ σ t)
substh {TERM} Γ ρ σ (Phi t t₁ t₂) = Phi (substh Γ ρ σ t) (substh Γ ρ σ t₁) (substh Γ ρ σ t₂)
substh {TERM} Γ ρ σ (Rho tₑ x T t) =
  let x' = subst-rename-var-if Γ ρ x σ T in
  Rho (substh Γ ρ σ tₑ) x' (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T) (substh Γ ρ σ t)
substh {TERM} Γ ρ σ (Delta b? T t) =
  Delta (b? >>=c λ t₁ t₂ → just (substh Γ ρ σ t₁ , substh Γ ρ σ t₂))
        (substh Γ ρ σ T) (substh Γ ρ σ t)
substh {TERM} Γ ρ σ (Mu (inj₂ x) t T t~ ms) =
  let fv = λ x → trie-contains σ x || ctxt-binds-var Γ x || renamectxt-in-field ρ x
      x' = fresh-h (λ x → fv x || fv (mu-Type/ x) || fv (mu-isType/ x))
                   (if x =string ignored-var then "x" else x)
      ρ' = renamectxt-insert ρ x x'
      ρ' = renamectxt-insert ρ' (mu-Type/ x) (mu-Type/ x')
      ρ' = renamectxt-insert ρ' (mu-isType/ x) (mu-isType/ x')
      Γ' = ctxt-var-decl x' Γ
      Γ' = ctxt-var-decl (mu-Type/ x') Γ'
      Γ' = ctxt-var-decl (mu-isType/ x') Γ' in
    Mu (inj₂ x') (substh Γ ρ σ t) (substh (ctxt-var-decl (mu-Type/ x') Γ) (renamectxt-insert ρ (mu-Type/ x) (mu-Type/ x')) σ <$> T) (substh-datatype-info Γ ρ σ t~) (substh-cases Γ' ρ' σ ms)
substh {TERM} Γ ρ σ (Mu (inj₁ tᵢ) t' T t~ ms) =
  Mu (inj₁ (substh Γ ρ σ <$> tᵢ)) (substh Γ ρ σ t') (substh Γ ρ σ <$> T) (substh-datatype-info Γ ρ σ t~) (substh-cases Γ ρ σ ms)

substh {TYPE} Γ ρ σ (TpAbs me x tk t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    TpAbs me x' (substh Γ ρ σ -tk tk)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TYPE} Γ ρ σ (TpLam x tk t) =
  let x' = subst-rename-var-if Γ ρ x σ t in
    TpLam x' (substh Γ ρ σ -tk tk)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh {TYPE} Γ ρ σ (TpIota x T₁ T₂) =
  let x' = subst-rename-var-if Γ ρ x σ T₂ in
    TpIota x' (substh Γ ρ σ T₁)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T₂)
substh {TYPE} Γ ρ σ (TpApp tp tT) = TpApp (substh Γ ρ σ tp) (substh Γ ρ σ -tT tT)
substh {TYPE} Γ ρ σ (TpEq t₁ t₂) = TpEq (substh Γ ρ σ t₁) (substh Γ ρ σ t₂)
substh {TYPE} Γ ρ σ (TpVar x) =
 let x' = renamectxt-rep ρ x in
   case trie-lookup σ x' of λ where
     (just (,_ {TYPE} T)) → T
     _ → TpVar x'
substh {TYPE} Γ ρ σ (TpHole pi) = TpHole pi -- Retain position, so jumping to hole works

substh {KIND} Γ ρ σ (KdAbs x tk k) =
  let x' = subst-rename-var-if Γ ρ x σ k in
    KdAbs x' (substh Γ ρ σ -tk tk)
      (substh (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ k)
substh {KIND} Γ ρ σ (KdHole pi) = KdHole pi -- Retain position, so jumping to hole works
substh {KIND} Γ ρ σ KdStar = KdStar

substh-datatype-info Γ ρ σ (mk-data-info X Xₒ asₚ asᵢ ps kᵢ k cs csₚₛ gds eds) =
  let Γ' = foldr (λ { (Param me x tk) Γ → ctxt-var-decl x Γ       }) Γ ps
      ρ' = foldr (λ { (Param me x tk) ρ → renamectxt-insert ρ x x }) ρ ps
      σ' = foldr (λ { (Param me x tk) σ → trie-remove σ x         }) σ ps in
  mk-data-info
    (renamectxt-rep ρ X)
    (renamectxt-rep ρ Xₒ)
    (substh Γ ρ σ -arg_ <$> asₚ)
    (substh Γ ρ σ -tT_ <$> asᵢ)
    ps
    (substh Γ' ρ' σ' kᵢ)
    (substh Γ' ρ' σ' k)
    (map-snd (substh Γ' ρ' σ') <$> cs)
    (map-snd (substh Γ ρ σ) <$> csₚₛ)
    gds
    eds

substh-arg Γ ρ σ = substh Γ ρ σ -arg_

substh-args Γ ρ σ = substh-arg Γ ρ σ <$>_

substh-params' Γ ρ σ ((Param me x tk) :: ps) =
  map-fst (Param me x (substh Γ ρ σ -tk tk) ::_)
    (substh-params' Γ (renamectxt-insert ρ x x) (trie-remove σ x) ps)
substh-params' Γ ρ σ [] = [] , Γ , ρ , σ

substh-params Γ ρ σ ps = fst (substh-params' Γ ρ σ ps)

substh-indices Γ ρ σ = params-to-indices ∘' substh-params Γ ρ σ ∘' indices-to-params

substh-case Γ ρ σ (Case x as t asₜₚ) =
  case (substh-case-args Γ ρ σ as) of λ where
    (as' , ρ' , Γ' , σ') →
      Case x as' (substh Γ' ρ' σ' t) (substh Γ' ρ' σ' -tT_ <$> asₜₚ)

substh-cases Γ ρ σ = map (substh-case Γ ρ σ)

substh-case-args Γ ρ σ as = foldr (λ where
  (CaseArg e x tk) f ρ Γ σ →
    let x' = subst-rename-var-if Γ ρ x σ (Var x) in
    map-fst (CaseArg e x' (substh Γ ρ σ -tk_ <$> tk) ::_)
            (f (renamectxt-insert ρ x x') (ctxt-var-decl x' Γ) (trie-remove σ x)))
  (λ ρ Γ σ → [] , ρ , Γ , σ) as ρ Γ σ

subst-ret-t : Set → Set
subst-ret-t T = {ed : exprd} → ctxt → ⟦ ed ⟧ → var → T → T

subst : ∀ {ed} → subst-ret-t ⟦ ed ⟧
subst Γ t x = substh Γ empty-renamectxt (trie-single x (, t))

subst-cases : subst-ret-t cases
subst-cases Γ t x = substh-cases Γ empty-renamectxt (trie-single x (, t))

subst-params : subst-ret-t params
subst-params Γ t x = substh-params Γ empty-renamectxt (trie-single x (, t))

subst-renamectxt : ∀ {ed : exprd} → ctxt → renamectxt → ⟦ ed ⟧ → ⟦ ed ⟧
subst-renamectxt Γ ρ = substh Γ ρ empty-trie

rename-var : ∀ {ed} → ctxt → var → var → ⟦ ed ⟧ → ⟦ ed ⟧
rename-var Γ x x' = subst-renamectxt Γ (renamectxt-single x x')

substs-ret-t : Set → Set
substs-ret-t T = ctxt → trie (Σi exprd ⟦_⟧) → T → T

substs : ∀ {ed} → substs-ret-t ⟦ ed ⟧
substs = flip substh empty-renamectxt

substs-args : substs-ret-t args
substs-args = flip substh-args empty-renamectxt

substs-params : substs-ret-t params
substs-params = flip substh-params empty-renamectxt

substs-cases : substs-ret-t cases
substs-cases = flip substh-cases empty-renamectxt

subst-params-args : params → args → trie (Σi exprd ⟦_⟧) × params × args
subst-params-args ps as = subst-params-args' ps as empty-trie where
  subst-params-args' : params → args → trie (Σi exprd ⟦_⟧) → trie (Σi exprd ⟦_⟧) × params × args
  subst-params-args' (Param me x tk :: ps) (Arg t :: as) σ =
    subst-params-args' ps as (trie-insert σ x (, t))
  subst-params-args' (Param me x tk :: ps) (ArgE (inj₁ t) :: as) σ =
    subst-params-args' ps as (trie-insert σ x (, t))
  subst-params-args' (Param me x tk :: ps) (ArgE (inj₂ T) :: as) σ =
    subst-params-args' ps as (trie-insert σ x (, T))
  subst-params-args' ps as σ = σ , ps , as

subst-params-args' : ctxt → params → args → ∀ {ed} → ⟦ ed ⟧ → ⟦ ed ⟧ × params × args
subst-params-args' Γ ps as t = map-fst (λ σ → substs Γ σ t) (subst-params-args ps as)

infixr 3 [_-_/_]_
[_-_/_]_ : ∀ {ed ed'} → ctxt → ⟦ ed ⟧ → var → ⟦ ed' ⟧ → ⟦ ed' ⟧
[ Γ - t / x ] t' = subst Γ t x t'

subst-unqual : ∀ {ed} → ctxt → 𝕃 (posinfo × var) → ⟦ ed ⟧ → ⟦ ed ⟧
subst-unqual Γ xs t =
  subst-renamectxt
    Γ
    (foldr (uncurry λ pi x xs → renamectxt-insert xs (pi % x) x) empty-renamectxt xs)
    t

-- Given the parameters (32@x : ...) (41@y : ...32@x...),
-- returns (x : ...) (y : ...x...) × (32@x → x, 41@y → y)
unqual-params : ctxt → params → params × renamectxt
unqual-params = h empty-renamectxt where
  h : renamectxt → ctxt → params → params × renamectxt
  h ρ Γ [] = [] , ρ
  h ρ Γ (Param me qx atk :: ps) =
    let x = unqual-local qx in
    map-fst (Param me x (subst-renamectxt Γ ρ -tk atk) ::_)
      (h (renamectxt-insert ρ qx x) (ctxt-var-decl x Γ) ps)


{-# OPTIONS --rewriting #-}

module Properties.ResolveOverloads where

open import FFI.Data.Either using (Left; Right)
open import Luau.ResolveOverloads using (Resolved; src; srcⁿ; resolve; resolveⁿ; resolveᶠ; resolveˢ; target; yes; no)
open import Luau.Subtyping using (_<:_; _≮:_; Language; ¬Language; witness; scalar; unknown; never; function; function-ok; function-err; function-tgt; function-scalar; function-ok₁; function-ok₂; scalar-scalar; scalar-function; scalar-function-ok; scalar-function-err; scalar-function-tgt; _,_; left; right)
open import Luau.Type using (Type ; Scalar; _⇒_; _∩_; _∪_; nil; boolean; number; string; unknown; never)
open import Luau.TypeSaturation using (saturate)
open import Luau.TypeNormalization using (normalize)
open import Properties.Contradiction using (CONTRADICTION)
open import Properties.DecSubtyping using (dec-subtyping; dec-subtypingⁿ; <:-impl-<:ᵒ)
open import Properties.Functions using (_∘_)
open import Properties.Subtyping using (<:-refl; <:-trans; <:-trans-≮:; ≮:-trans-<:; <:-∩-left; <:-∩-right; <:-∩-glb; <:-impl-¬≮:; <:-unknown; <:-function; function-≮:-never; <:-never; unknown-≮:-function; scalar-≮:-function; ≮:-∪-right; scalar-≮:-never; <:-∪-left; <:-∪-right; <:-impl-⊇; language-comp)
open import Properties.TypeNormalization using (Normal; FunType; normal; _⇒_; _∩_; _∪_; never; unknown; <:-normalize; normalize-<:; fun-≮:-never; unknown-≮:-fun; scalar-≮:-fun)
open import Properties.TypeSaturation using (Overloads; Saturated; _⊆ᵒ_; _<:ᵒ_; normal-saturate; saturated; <:-saturate; saturate-<:; defn; here; left; right)

-- Properties of src
function-err-srcⁿ : ∀ {T t} → (FunType T) → (¬Language (srcⁿ T) t) → Language T (function-err t)
function-err-srcⁿ (S ⇒ T) p = function-err p
function-err-srcⁿ (S ∩ T) (p₁ , p₂) = (function-err-srcⁿ S p₁ , function-err-srcⁿ T p₂)

¬function-err-srcᶠ : ∀ {T t} → (FunType T) → (Language (srcⁿ T) t) → ¬Language T (function-err t)
¬function-err-srcᶠ (S ⇒ T) p = function-err p
¬function-err-srcᶠ (S ∩ T) (left p) = left (¬function-err-srcᶠ S p)
¬function-err-srcᶠ (S ∩ T) (right p) = right (¬function-err-srcᶠ T p)

¬function-err-srcⁿ : ∀ {T t} → (Normal T) → (Language (srcⁿ T) t) → ¬Language T (function-err t)
¬function-err-srcⁿ never p = never
¬function-err-srcⁿ unknown (scalar ())
¬function-err-srcⁿ (S ⇒ T) p = function-err p
¬function-err-srcⁿ (S ∩ T) (left p) = left (¬function-err-srcᶠ S p)
¬function-err-srcⁿ (S ∩ T) (right p) = right (¬function-err-srcᶠ T p)
¬function-err-srcⁿ (S ∪ T) (scalar ())

¬function-err-src : ∀ {T t} → (Language (src T) t) → ¬Language T (function-err t)
¬function-err-src {T = S ⇒ T} p = function-err p
¬function-err-src {T = nil} p = scalar-function-err nil
¬function-err-src {T = never} p = never
¬function-err-src {T = unknown} (scalar ())
¬function-err-src {T = boolean} p = scalar-function-err boolean
¬function-err-src {T = number} p = scalar-function-err number
¬function-err-src {T = string} p = scalar-function-err string
¬function-err-src {T = S ∪ T} p = <:-impl-⊇ (<:-normalize (S ∪ T)) _ (¬function-err-srcⁿ (normal (S ∪ T)) p)
¬function-err-src {T = S ∩ T} p = <:-impl-⊇ (<:-normalize (S ∩ T)) _ (¬function-err-srcⁿ (normal (S ∩ T)) p)

src-¬function-errᶠ : ∀ {T t} → (FunType T) → Language T (function-err t) → (¬Language (srcⁿ T) t)
src-¬function-errᶠ (S ⇒ T) (function-err p) = p
src-¬function-errᶠ (S ∩ T) (p₁ , p₂) = (src-¬function-errᶠ S p₁ , src-¬function-errᶠ T p₂)

src-¬function-errⁿ : ∀ {T t} → (Normal T) → Language T (function-err t) → (¬Language (srcⁿ T) t)
src-¬function-errⁿ unknown p = never
src-¬function-errⁿ (S ⇒ T) (function-err p) = p
src-¬function-errⁿ (S ∩ T) (p₁ , p₂) = (src-¬function-errᶠ S p₁ , src-¬function-errᶠ T p₂)
src-¬function-errⁿ (S ∪ T) p = never

src-¬function-err : ∀ {T t} → Language T (function-err t) → (¬Language (src T) t)
src-¬function-err {T = S ⇒ T} (function-err p) = p
src-¬function-err {T = unknown} p = never
src-¬function-err {T = S ∪ T} p = src-¬function-errⁿ (normal (S ∪ T)) (<:-normalize (S ∪ T) _ p)
src-¬function-err {T = S ∩ T} p = src-¬function-errⁿ (normal (S ∩ T)) (<:-normalize (S ∩ T) _ p)

fun-¬scalar : ∀ {S T} (s : Scalar S) → FunType T → ¬Language T (scalar s)
fun-¬scalar s (S ⇒ T) = function-scalar s
fun-¬scalar s (S ∩ T) = left (fun-¬scalar s S)

¬fun-scalar : ∀ {S T t} (s : Scalar S) → FunType T → Language T t → ¬Language S t
¬fun-scalar s (S ⇒ T) function = scalar-function s
¬fun-scalar s (S ⇒ T) (function-ok₁ p) = scalar-function-ok s
¬fun-scalar s (S ⇒ T) (function-ok₂ p) = scalar-function-ok s
¬fun-scalar s (S ⇒ T) (function-err p) = scalar-function-err s
¬fun-scalar s (S ⇒ T) (function-tgt p) = scalar-function-tgt s
¬fun-scalar s (S ∩ T) (p₁ , p₂) = ¬fun-scalar s T p₂

fun-function : ∀ {T} → FunType T → Language T function
fun-function (S ⇒ T) = function
fun-function (S ∩ T) = (fun-function S , fun-function T)

srcⁿ-¬scalar : ∀ {S T t} (s : Scalar S) → Normal T → Language T (scalar s) → (¬Language (srcⁿ T) t)
srcⁿ-¬scalar s never (scalar ())
srcⁿ-¬scalar s unknown p = never
srcⁿ-¬scalar s (S ⇒ T) (scalar ())
srcⁿ-¬scalar s (S ∩ T) (p₁ , p₂) = CONTRADICTION (language-comp (scalar s) (fun-¬scalar s S) p₁)
srcⁿ-¬scalar s (S ∪ T) p = never

src-¬scalar : ∀ {S T t} (s : Scalar S) → Language T (scalar s) → (¬Language (src T) t)
src-¬scalar {T = nil} s p = never
src-¬scalar {T = T ⇒ U} s (scalar ())
src-¬scalar {T = never} s (scalar ())
src-¬scalar {T = unknown} s p = never
src-¬scalar {T = boolean} s p = never
src-¬scalar {T = number} s p = never
src-¬scalar {T = string} s p = never
src-¬scalar {T = T ∪ U} s p = srcⁿ-¬scalar s (normal (T ∪ U)) (<:-normalize (T ∪ U) (scalar s) p)
src-¬scalar {T = T ∩ U} s p = srcⁿ-¬scalar s (normal (T ∩ U)) (<:-normalize (T ∩ U) (scalar s) p)

srcⁿ-unknown-≮: : ∀ {T U} → (Normal U) → (T ≮: srcⁿ U) → (U ≮: (T ⇒ unknown))
srcⁿ-unknown-≮: never (witness t p q) = CONTRADICTION (language-comp t q unknown)
srcⁿ-unknown-≮: unknown (witness t p q) = witness (function-err t) unknown (function-err p)
srcⁿ-unknown-≮: (U ⇒ V) (witness t p q) = witness (function-err t) (function-err q) (function-err p)
srcⁿ-unknown-≮: (U ∩ V) (witness t p q) = witness (function-err t) (function-err-srcⁿ (U ∩ V) q) (function-err p)
srcⁿ-unknown-≮: (U ∪ V) (witness t p q) = witness (scalar V) (right (scalar V)) (function-scalar V)

src-unknown-≮: : ∀ {T U} → (T ≮: src U) → (U ≮: (T ⇒ unknown))
src-unknown-≮: {U = nil} (witness t p q) = witness (scalar nil) (scalar nil) (function-scalar nil)
src-unknown-≮: {U = T ⇒ U} (witness t p q) = witness (function-err t) (function-err q) (function-err p)
src-unknown-≮: {U = never} (witness t p q) = CONTRADICTION (language-comp t q unknown)
src-unknown-≮: {U = unknown} (witness t p q) = witness (function-err t) unknown (function-err p)
src-unknown-≮: {U = boolean} (witness t p q) = witness (scalar boolean) (scalar boolean) (function-scalar boolean)
src-unknown-≮: {U = number} (witness t p q) = witness (scalar number) (scalar number) (function-scalar number)
src-unknown-≮: {U = string} (witness t p q) = witness (scalar string) (scalar string) (function-scalar string)
src-unknown-≮: {U = T ∪ U} p = <:-trans-≮: (normalize-<: (T ∪ U)) (srcⁿ-unknown-≮: (normal (T ∪ U)) p)
src-unknown-≮: {U = T ∩ U} p = <:-trans-≮: (normalize-<: (T ∩ U)) (srcⁿ-unknown-≮: (normal (T ∩ U)) p)

unknown-src-≮: : ∀ {S T U} → (U ≮: S) → (T ≮: (U ⇒ unknown)) → (U ≮: src T)
unknown-src-≮: (witness t x x₁) (witness (scalar s) p (function-scalar s)) = witness t x (src-¬scalar s p)
unknown-src-≮: r (witness (function-ok s .(scalar s₁)) p (function-ok x (scalar-scalar s₁ () x₂)))
unknown-src-≮: r (witness (function-ok s .function) p (function-ok x (scalar-function ())))
unknown-src-≮: r (witness (function-ok s .(function-ok _ _)) p (function-ok x (scalar-function-ok ())))
unknown-src-≮: r (witness (function-ok s .(function-err _)) p (function-ok x (scalar-function-err ())))
unknown-src-≮: r (witness (function-err t) p (function-err q)) = witness t q (src-¬function-err p)
unknown-src-≮: r (witness (function-tgt t) p (function-tgt (scalar-function-tgt ())))

-- Properties of resolve
resolveˢ-<:-⇒ : ∀ {F V U} → (FunType F) → (Saturated F) → (FunType (V ⇒ U)) → (r : Resolved F V) → (F <: (V ⇒ U)) → (target r <: U)
resolveˢ-<:-⇒ Fᶠ Fˢ V⇒Uᶠ r F<:V⇒U with <:-impl-<:ᵒ Fᶠ Fˢ V⇒Uᶠ F<:V⇒U here
resolveˢ-<:-⇒ Fᶠ Fˢ V⇒Uᶠ (yes Sʳ Tʳ oʳ V<:Sʳ tgtʳ) F<:V⇒U | defn o o₁ o₂ = <:-trans (tgtʳ o o₁) o₂
resolveˢ-<:-⇒ Fᶠ Fˢ V⇒Uᶠ (no tgtʳ) F<:V⇒U | defn o o₁ o₂ = CONTRADICTION (<:-impl-¬≮: o₁ (tgtʳ o))

resolveⁿ-<:-⇒ : ∀ {F V U} → (Fⁿ : Normal F) → (Vⁿ : Normal V) → (Uⁿ : Normal U) → (F <: (V ⇒ U)) → (resolveⁿ Fⁿ Vⁿ <: U)
resolveⁿ-<:-⇒ (Sⁿ ⇒ Tⁿ) Vⁿ Uⁿ F<:V⇒U = resolveˢ-<:-⇒ (normal-saturate (Sⁿ ⇒ Tⁿ)) (saturated (Sⁿ ⇒ Tⁿ)) (Vⁿ ⇒ Uⁿ) (resolveˢ (normal-saturate (Sⁿ ⇒ Tⁿ)) (saturated (Sⁿ ⇒ Tⁿ)) Vⁿ (λ o → o)) F<:V⇒U
resolveⁿ-<:-⇒ (Fⁿ ∩ Gⁿ) Vⁿ Uⁿ F<:V⇒U = resolveˢ-<:-⇒ (normal-saturate (Fⁿ ∩ Gⁿ)) (saturated (Fⁿ ∩ Gⁿ)) (Vⁿ ⇒ Uⁿ) (resolveˢ (normal-saturate (Fⁿ ∩ Gⁿ)) (saturated (Fⁿ ∩ Gⁿ)) Vⁿ (λ o → o)) (<:-trans (saturate-<: (Fⁿ ∩ Gⁿ)) F<:V⇒U)
resolveⁿ-<:-⇒ (Sⁿ ∪ Tˢ) Vⁿ Uⁿ F<:V⇒U = CONTRADICTION (<:-impl-¬≮: F<:V⇒U (<:-trans-≮: <:-∪-right (scalar-≮:-function Tˢ)))
resolveⁿ-<:-⇒ never Vⁿ Uⁿ F<:V⇒U = <:-never
resolveⁿ-<:-⇒ unknown Vⁿ Uⁿ F<:V⇒U = CONTRADICTION (<:-impl-¬≮: F<:V⇒U unknown-≮:-function)

resolve-<:-⇒ : ∀ {F V U} → (F <: (V ⇒ U)) → (resolve F V <: U)
resolve-<:-⇒ {F} {V} {U} F<:V⇒U = <:-trans (resolveⁿ-<:-⇒ (normal F) (normal V) (normal U) (<:-trans (normalize-<: F) (<:-trans F<:V⇒U (<:-normalize (V ⇒ U))))) (normalize-<: U)

resolve-≮:-⇒ : ∀ {F V U} → (resolve F V ≮: U) → (F ≮: (V ⇒ U))
resolve-≮:-⇒ {F} {V} {U} FV≮:U with dec-subtyping F (V ⇒ U)
resolve-≮:-⇒ {F} {V} {U} FV≮:U | Left F≮:V⇒U = F≮:V⇒U
resolve-≮:-⇒ {F} {V} {U} FV≮:U | Right F<:V⇒U = CONTRADICTION (<:-impl-¬≮: (resolve-<:-⇒ F<:V⇒U) FV≮:U)

<:-resolveˢ-⇒ : ∀ {S T V} → (r : Resolved (S ⇒ T) V) → (V <: S) → T <: target r
<:-resolveˢ-⇒ (yes S T here _ _) V<:S = <:-refl
<:-resolveˢ-⇒ (no _) V<:S = <:-unknown

<:-resolveⁿ-⇒ : ∀ {S T V} → (Sⁿ : Normal S) → (Tⁿ : Normal T) → (Vⁿ : Normal V) → (V <: S) → T <: resolveⁿ (Sⁿ ⇒ Tⁿ) Vⁿ
<:-resolveⁿ-⇒ Sⁿ Tⁿ Vⁿ V<:S = <:-resolveˢ-⇒ (resolveˢ (Sⁿ ⇒ Tⁿ) (saturated (Sⁿ ⇒ Tⁿ)) Vⁿ (λ o → o)) V<:S

<:-resolve-⇒ : ∀ {S T V} → (V <: S) → T <: resolve (S ⇒ T) V
<:-resolve-⇒ {S} {T} {V} V<:S = <:-trans (<:-normalize T) (<:-resolveⁿ-⇒ (normal S) (normal T) (normal V) (<:-trans (normalize-<: V) (<:-trans V<:S (<:-normalize S))))

<:-resolveˢ : ∀ {F G V W} → (r : Resolved F V) → (s : Resolved G W) → (F <:ᵒ G) → (V <: W) → target r <: target s
<:-resolveˢ (yes Sʳ Tʳ oʳ V<:Sʳ tgtʳ) (yes Sˢ Tˢ oˢ  W<:Sˢ tgtˢ) F<:G V<:W with F<:G oˢ
<:-resolveˢ (yes Sʳ Tʳ oʳ V<:Sʳ tgtʳ) (yes Sˢ Tˢ oˢ W<:Sˢ tgtˢ) F<:G V<:W | defn o o₁ o₂ = <:-trans (tgtʳ o (<:-trans (<:-trans V<:W W<:Sˢ) o₁)) o₂
<:-resolveˢ (no r) (yes Sˢ Tˢ oˢ  W<:Sˢ tgtˢ) F<:G V<:W with F<:G oˢ
<:-resolveˢ (no r) (yes Sˢ Tˢ oˢ  W<:Sˢ tgtˢ) F<:G V<:W | defn o o₁ o₂ = CONTRADICTION (<:-impl-¬≮: (<:-trans V<:W (<:-trans W<:Sˢ o₁)) (r o))
<:-resolveˢ r (no s) F<:G V<:W = <:-unknown

<:-resolveᶠ : ∀ {F G V W} → (Fᶠ : FunType F) → (Gᶠ : FunType G) → (Vⁿ : Normal V) → (Wⁿ : Normal W) → (F <: G) → (V <: W) → resolveᶠ Fᶠ Vⁿ <: resolveᶠ Gᶠ Wⁿ
<:-resolveᶠ Fᶠ Gᶠ Vⁿ Wⁿ F<:G V<:W = <:-resolveˢ
  (resolveˢ (normal-saturate Fᶠ) (saturated Fᶠ) Vⁿ (λ o → o))
  (resolveˢ (normal-saturate Gᶠ) (saturated Gᶠ) Wⁿ (λ o → o))
  (<:-impl-<:ᵒ (normal-saturate Fᶠ) (saturated Fᶠ) (normal-saturate Gᶠ) (<:-trans (saturate-<: Fᶠ) (<:-trans F<:G (<:-saturate Gᶠ))))
  V<:W

<:-resolveⁿ : ∀ {F G V W} → (Fⁿ : Normal F) → (Gⁿ : Normal G) → (Vⁿ : Normal V) → (Wⁿ : Normal W) → (F <: G) → (V <: W) → resolveⁿ Fⁿ Vⁿ <: resolveⁿ Gⁿ Wⁿ
<:-resolveⁿ (Rⁿ ⇒ Sⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Rⁿ ⇒ Sⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Rⁿ ⇒ Sⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Rⁿ ⇒ Sⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Eⁿ ∩ Fⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Eⁿ ∩ Fⁿ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Eⁿ ∩ Fⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = <:-resolveᶠ (Eⁿ ∩ Fⁿ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W
<:-resolveⁿ (Fⁿ ∪ Sˢ) (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (≮:-∪-right (scalar-≮:-function Sˢ)))
<:-resolveⁿ unknown (Tⁿ ⇒ Uⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G unknown-≮:-function)
<:-resolveⁿ (Fⁿ ∪ Sˢ) (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (≮:-∪-right (scalar-≮:-fun (Gⁿ ∩ Hⁿ) Sˢ)))
<:-resolveⁿ unknown (Gⁿ ∩ Hⁿ) Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (unknown-≮:-fun (Gⁿ ∩ Hⁿ)))
<:-resolveⁿ (Rⁿ ⇒ Sⁿ) never Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (fun-≮:-never (Rⁿ ⇒ Sⁿ)))
<:-resolveⁿ (Eⁿ ∩ Fⁿ) never Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (fun-≮:-never (Eⁿ ∩ Fⁿ)))
<:-resolveⁿ (Fⁿ ∪ Sˢ) never Vⁿ Wⁿ F<:G V<:W = CONTRADICTION (<:-impl-¬≮: F<:G (≮:-∪-right (scalar-≮:-never Sˢ)))
<:-resolveⁿ unknown never Vⁿ Wⁿ F<:G V<:W = F<:G
<:-resolveⁿ never Gⁿ Vⁿ Wⁿ F<:G V<:W = <:-never
<:-resolveⁿ Fⁿ (Gⁿ ∪ Uˢ) Vⁿ Wⁿ F<:G V<:W = <:-unknown
<:-resolveⁿ Fⁿ unknown Vⁿ Wⁿ F<:G V<:W = <:-unknown

<:-resolve : ∀ {F G V W} → (F <: G) → (V <: W) → resolve F V <: resolve G W
<:-resolve {F} {G} {V} {W} F<:G V<:W = <:-resolveⁿ (normal F) (normal G) (normal V) (normal W)
  (<:-trans (normalize-<: F) (<:-trans F<:G (<:-normalize G)))
  (<:-trans (normalize-<: V) (<:-trans V<:W (<:-normalize W)))