Helios: better account to the "query hacking"

open import Type
open import Function
open import Data.List
open import Data.Vec using (Vec; []; _∷_)
open import Data.Fin using (Fin; zero; suc) renaming (toℕ to Fin▹ℕ)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd) hiding (zip; map)
{-
open import Data.Zero
open import Data.One
-}
open import Data.Two
open import Data.Nat.NP hiding (_==_; _<_)
--open import Control.Strategy

module Helios
  (VoterId : ★)
  (PublicKey : ★)
  (SecretKey : ★)
  (NIZKSecretKey : PublicKey → ★)
  (Vote   : ★)
  (Ballot : ★)
  (Decryption-share : ★)
  (PublicInfo : ★)
  (R-setup : ★)
  (R-vote : ★)
  (vote : PublicKey → R-vote → VoterId → Vote → Ballot)
  {-
  (let Ballots = List (VoterId × Ballot)
       Decryption-shares = List Decryption-share
  )
  -}
  (validate-ballots :
     let Ballots = List (VoterId × Ballot)
         Decryption-shares = List Decryption-share in
     PublicKey → Ballots → 𝟚)
  (Tally : ★) -- could be a valid tally or a special symbol ⊥
  (fake-decrytion-share :
     let Ballots = List (VoterId × Ballot)
         Decryption-shares = List Decryption-share in
     Tally → Ballots → Decryption-share)
  (R-adversary : ★)
  where

Ballots = List (VoterId × Ballot)
Decryption-shares = List Decryption-share

module _ {A : ★} where
  map-nᵗʰ : ℕ → (A → A) → List A → List A
  map-nᵗʰ n       f []       = []
  map-nᵗʰ zero    f (x ∷ xs) = f x ∷ xs
  map-nᵗʰ (suc n) f (x ∷ xs) = x ∷ map-nᵗʰ n f xs

_<_ : ℕ → ℕ → 𝟚
x < y = suc x <= y

module _ {k : ℕ} {- sequences -} where
     Seq : ★ → ★
     Seq A = Fin k → A

     {-
     replicateSeq : {A : ★} → Fin k → A → A → Seq A
     replicateSeq n x y i = case {!(i < n)!} 0: x 1: y
     -}

record KeyPair : ★ where
  constructor mk
  field
    pk : PublicKey
    sk : SecretKey
    zk : NIZKSecretKey pk

record BB : ★ where
  constructor <_,,_,,_,,_>
  field
    Y-pk              : PublicKey
    π-pk              : NIZKSecretKey Y-pk
    ballots           : Ballots
    decryption-shares : Decryption-shares
open BB public

Make-decryption-shares = KeyPair → Ballots → Decryption-shares
Simulate-decryption-shares = (bs₀ : Ballots) → Make-decryption-shares

validate : PublicKey → Ballots → VoterId × Ballot → 𝟚
validate pk bs vb = validate-ballots pk (vb ∷ bs)

data Q : ★ where
  ask-vote   : (v_ : Vote ²) → Q
  ask-ballot : (b  : Ballot) → Q

map-vote²-Q : (Vote ² → Vote ²) → Q → Q
map-vote²-Q f (ask-vote v_) = ask-vote (f v_)
map-vote²-Q f (ask-ballot b) = ask-ballot b

VotingPhase₀ : ★
VotingPhase₀ = Ballots → VoterId × Q

VotingPhase : ★
VotingPhase = List VotingPhase₀

module Tallying
  (decryption-shares : Make-decryption-shares)
  (result : BB → Tally)
  where

  tally-bb : KeyPair → Ballots → BB
  tally-bb (mk Y sk zk) bs = < Y ,, zk ,, bs ,, decryption-shares (mk Y sk zk) bs >

  tally : KeyPair → Ballots → Tally
  tally kp bs = result (tally-bb kp bs)

module Run-common (pk : PublicKey) where
    run-vote-query¹ : R-vote → VoterId → Vote → Ballots → Ballots
    run-vote-query¹ r-vote vid v bs = case validate pk bs (vid , b)
                                        0: bs
                                        1: ((vid , b) ∷ bs)
      where
        b : Ballot
        b = vote pk r-vote vid v

    run-vote-query : R-vote ² → VoterId → Vote ² → Ballots ² → Ballots ²
    run-vote-query r-vote vid v_ bs_ i = run-vote-query¹ (r-vote i) vid (v_ i) (bs_ i)

    run-ballot-query : (β : 𝟚) → VoterId → Ballot → Ballots ² → Ballots ²
    run-ballot-query β vid b bs_ i =
        case validate pk (bs_ β) (vid , b)
          0: bs_ i
          1: case validate pk (bs_ (not β)) (vid , b)
               0: case i
                    0: ((vid , b) ∷ bs_ 0₂)
                    1: bs_ 1₂
               1: ((vid , b) ∷ bs_ i)

module Run (β : 𝟚) (pk : PublicKey) where
    open Run-common pk

    run-query : R-vote ² → VoterId → Q → Ballots ² → Ballots ²
    run-query r-vote vid (ask-vote v_)  = run-vote-query r-vote vid v_
    run-query r-vote vid (ask-ballot b) = run-ballot-query β vid b

    run-voting-phase : List (VotingPhase₀ × R-vote ²) → Ballots ² → Ballots ²
    run-voting-phase []                  bs_ = bs_
    run-voting-phase ((q , r-vote) ∷ qs) bs_ =
       run-voting-phase qs (uncurry (run-query r-vote) (q (bs_ β)) bs_)

Hack-run-vote-query : ℕ → ★
Hack-run-vote-query #q = Fin #q → 𝟚 → 𝟚

module _ {-(max-q-1 : ℕ)-} where
  -- max-q = ℕ.suc max-q-1
  Adversary = R-adversary →
              PublicKey →
              -- Σ _ λ (#q : Fin max-q) →
              VotingPhase × -- (Fin▹ℕ #q) ×
              (BB →
              𝟚)

  map-vote²-in-voting-phase : (Vote ² → Vote ²) → VotingPhase₀ → VotingPhase₀
  map-vote²-in-voting-phase f = _∘_ (second (map-vote²-Q f))

  map-Advesary : (VotingPhase → VotingPhase) → Adversary → Adversary
  map-Advesary f A rₐ pk = first f (A rₐ pk)

  module CommonChallenger
              (setup : R-setup → KeyPair)
              (r-setup : R-setup)
              (r-adversary : R-adversary)
              (A : Adversary)
              where
    kp = setup r-setup
    open KeyPair kp public

    A-setup = A r-adversary pk

    A-voting-phase : VotingPhase
    A-voting-phase = fst A-setup

  -- The real challenger (has access to β)
  module Game (setup : R-setup → KeyPair)
              (decryption-shares : Make-decryption-shares)

              (r-setup : R-setup)
              (r-adversary : R-adversary)
              (A : Adversary)
              -- (hack-run-vote-queries : VotingPhase → VotingPhase)
              -- (hack-run-vote-query : (x : Fin max-q) → Hack-run-vote-query (Fin▹ℕ x))
              (r-votes : List (R-vote ²))
              (simulate-decryption-shares : Simulate-decryption-shares)
              (β : 𝟚)
              where

    open CommonChallenger setup r-setup r-adversary A public

    open Run β pk

    -- zip : ∀ {n m} {o : Fin n} (xs : Vec A (Fin▹ℕ o)) (ys : Vec A

    voting-phase : List (VotingPhase₀ × R-vote ²)
    voting-phase = zip A-voting-phase r-votes

    bs_ : Ballots ²
    bs_ = run-voting-phase voting-phase (const [])

    decryption-shares-β =
      (case β
         0: decryption-shares
         1: simulate-decryption-shares (bs_ 0₂))
      kp (bs_ β)

    bb : BB
    bb = record { Y-pk = pk ; π-pk = zk ; ballots = bs_ β ; decryption-shares = decryption-shares-β }

    exp : 𝟚
    exp = snd A-setup bb

    game = exp == β

  module Unused-simulate-decryption-shares
              (decryption-shares : Make-decryption-shares)
              (result : BB → Tally)
              (kp  : KeyPair)
              (bs_ : Ballots ²)
           where
    open KeyPair kp
    open Tallying decryption-shares result
    simulated-decryption-shares : Decryption-shares
    simulated-decryption-shares = fake-decrytion-share (tally kp (bs_ 0₂)) (bs_ 1₂) ∷ []

    {-
  module Simulated-Challenger
              (r-setup : R-setup)
              (r-votes : VoterId → R-vote ²)
              (r-adversary : R-adversary)
              (A : Adversary)
            where
    open CommonChallenger r-setup r-adversary A public
-}
  module Proof (setup : R-setup → KeyPair)
               (result : BB → Tally)
               (decryption-shares  decryption-sharesₐ : Make-decryption-shares)
               (r-setup : R-setup)
               (r-adversary : R-adversary)
               (A : Adversary)
               -- (r-votes : (x : Fin max-q) (y : Fin (Fin▹ℕ x)) → R-vote ²)
               (r-votes : List (R-vote ²))
               (simulate-decryption-shares : Simulate-decryption-shares)
               (simulate-zksecret : (pk : PublicKey) → NIZKSecretKey pk)
               where
     hack-voting-phase₀ = map-vote²-in-voting-phase (λ v i → v (not i))

     hack-all-queries : Adversary → Adversary
     hack-all-queries = map-Advesary (map hack-voting-phase₀)

     hack-query : ℕ → Adversary → Adversary
     hack-query n = map-Advesary (map-nᵗʰ n hack-voting-phase₀)

     hack-upto : ℕ → Adversary → Adversary
     hack-upto zero    = id
     hack-upto (suc n) = hack-upto n ∘ hack-query n

     module EXP = Game setup decryption-shares r-setup r-adversary A r-votes simulate-decryption-shares
     G₀ = EXP.exp 0₂
     G₁ = EXP.exp 1₂

     setupₐ : R-setup → KeyPair
     setupₐ r-setup = record (setup r-setup) { zk = simulate-zksecret _ }

     {-
     from G₀
       change setup             to setupₐ
       change decryption-shares to decryption-sharesₐ

       because β ≡ 0₂ simulate-decryption-shares is not used
     -}
     module EXPₐ = Game setupₐ decryption-sharesₐ r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     Gₐ = EXPₐ.exp

     -- TODO: G₀ ≈ Gₐ

     simulate-decryption-shares-B : Make-decryption-shares
     simulate-decryption-shares-B kp bs = fake-decrytion-share t bs ∷ []
       where
         open Tallying decryption-sharesₐ result
         t  = tally kp bs

     {-
     from Gₐ
       change decryption-sharesₐ to simulate-decryption-shares-B
     -}
     module EXP-B = Game setupₐ simulate-decryption-shares-B r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂
     G-B = EXP-B.exp

     {-
     G-C-last 0 is EXP-B
     -}
     module EXP-C-nᵗʰ (n : ℕ) = Game setupₐ simulate-decryption-shares-B r-setup r-adversary (hack-query n A) r-votes (λ _ _ _ → {- unused -} []) 0₂
     module EXP-C-upto (n : ℕ) = Game setupₐ simulate-decryption-shares-B r-setup r-adversary (hack-upto n A) r-votes (λ _ _ _ → {- unused -} []) 0₂

     {-
     like G-B but all vote queries are "hacked", namely moved from left(0₂) to right(1₂)
     -}
     module EXP-C = Game setupₐ simulate-decryption-shares-B r-setup r-adversary (hack-all-queries A) r-votes (λ _ _ _ → {- unused -} []) 0₂
     G-C = EXP-C.exp

     {- (revert Gₐ→G-B)
     from G-C
       change simulate-decryption-shares-B to decryption-sharesₐ
     -}
     module EXP-D = Game setupₐ decryption-sharesₐ r-setup r-adversary (hack-all-queries A) r-votes (λ _ _ _ → {- unused -} []) 0₂
     G-D = EXP-D.exp

     {- (revert G₀→Gₐ)
     from G-D
       change setupₐ             to setup
       change decryption-sharesₐ to decryption-shares
     -}
     module EXP-E = Game setup decryption-shares r-setup r-adversary (hack-all-queries A) r-votes (λ _ _ _ → {- unused -} []) 0₂
     G-E = EXP-E.exp

     -- G-E ≈ G₁

-- -}
-- -}
-- -}
-- -}
-- -}

open import Type
open import Function
open import Data.List
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
{-
open import Data.Zero
open import Data.One
-}
open import Data.Two
open import Data.Nat.NP hiding (_==_; _<_)
open import Control.Strategy

module Helios
  (VoterId : ★)
  (PublicKey : ★)
  (SecretKey : ★)
  (NIZKSecretKey : PublicKey → ★)
  (Vote   : ★)
  (Ballot : ★)
  (Decryption-share : ★)
  (PublicInfo : ★)
  (R-setup : ★)
  (R-vote : ★)
  (vote : PublicKey → R-vote → VoterId → Vote → Ballot)
  (let Ballots = List (VoterId × Ballot)
       Decryption-shares = List Decryption-share
  )
  (validate-ballots : PublicKey → Ballots → 𝟚)
  (Tally : ★) -- could be a valid tally or a special symbol ⊥
  (fake-decrytion-share : Tally → Ballots → Decryption-share)
  (R-adversary : ★)
  where

record KeyPair : ★ where
  constructor mk
  field
    pk : PublicKey
    sk : SecretKey
    zk : NIZKSecretKey pk

record BB : ★ where
  constructor <_,,_,,_,,_>
  field
    Y-pk              : PublicKey
    π-pk              : NIZKSecretKey Y-pk
    ballots           : Ballots
    decryption-shares : Decryption-shares
open BB public

Make-decryption-shares = KeyPair → Ballots → Decryption-shares
Simulate-decryption-shares = (bs₀ : Ballots) → Make-decryption-shares

validate : PublicKey → Ballots → VoterId × Ballot → 𝟚
validate pk bs vb = validate-ballots pk (vb ∷ bs)

data Q : ★ where
  ask-vote   : (v_ : Vote ²) → Q
  ask-ballot : (b  : Ballot) → Q

VotingPhase = List (Ballots → VoterId × Q)

module Tallying
  (decryption-shares : Make-decryption-shares)
  (result : BB → Tally)
  where

  tally-bb : KeyPair → Ballots → BB
  tally-bb (mk Y sk zk) bs = < Y ,, zk ,, bs ,, decryption-shares (mk Y sk zk) bs >

  tally : KeyPair → Ballots → Tally
  tally kp bs = result (tally-bb kp bs)

module Run-common
           (pk : PublicKey)
           (r-votes : VoterId → R-vote ²) where
    run-vote-query¹ : R-vote → VoterId → Vote → Ballots → Ballots
    run-vote-query¹ r-vote vid v bs = case validate pk bs (vid , b)
                                        0: bs
                                        1: ((vid , b) ∷ bs)
      where
        b : Ballot
        b = vote pk r-vote vid v

    run-vote-query : (hack-run-vote-query : 𝟚 → 𝟚) → VoterId → Vote ² → Ballots ² → Ballots ²
    run-vote-query hack-run-vote-query vid v_ bs_ i = run-vote-query¹ (r-votes vid i) vid (v_ (hack-run-vote-query i)) (bs_ i)

    run-ballot-query : (β : 𝟚) → VoterId → Ballot → Ballots ² → Ballots ²
    run-ballot-query β vid b bs_ i =
        case validate pk (bs_ β) (vid , b)
          0: bs_ i
          1: case validate pk (bs_ (not β)) (vid , b)
               0: case i
                    0: ((vid , b) ∷ bs_ 0₂)
                    1: bs_ 1₂
               1: ((vid , b) ∷ bs_ i)

Hack-run-vote-query = ℕ → 𝟚 → 𝟚

module Run (β : 𝟚)
           (hack-run-vote-query : Hack-run-vote-query)
           (pk : PublicKey)
           (r-votes : VoterId → R-vote ²) where
    open Run-common pk r-votes

    run-query : (hack-run-vote-query : 𝟚 → 𝟚) → VoterId → Q → Ballots ² → Ballots ²
    run-query hack-run-vote-query vid (ask-vote v_)  = run-vote-query hack-run-vote-query vid v_
    run-query hack-run-vote-query vid (ask-ballot b) = run-ballot-query β vid b

    run-voting-phase : VotingPhase → Ballots ² → Ballots ²
    run-voting-phase []       bs_ = bs_
    run-voting-phase (q ∷ qs) bs_ = run-voting-phase qs (uncurry (run-query (hack-run-vote-query (length qs))) (q (bs_ β)) bs_)

module _ where
  Adversary = R-adversary →
              PublicKey →
              VotingPhase ×
              (BB →
              𝟚)

  module CommonChallenger
              (setup : R-setup → KeyPair)
              (r-setup : R-setup)
              (r-adversary : R-adversary)
              (A : Adversary)
              where
    kp = setup r-setup
    open KeyPair kp public

    A-setup = A r-adversary pk

    A-voting-phase : VotingPhase
    A-voting-phase = fst A-setup

  -- The real challenger (has access to β)
  module Game (setup : R-setup → KeyPair)
              (decryption-shares : Make-decryption-shares)
              (hack-run-vote-query : Hack-run-vote-query)

              (r-setup : R-setup)
              (r-adversary : R-adversary)
              (A : Adversary)
              (r-votes : VoterId → R-vote ²)
              (simulate-decryption-shares : Simulate-decryption-shares)
              (β : 𝟚)
              where
    open CommonChallenger setup r-setup r-adversary A public

    open Run β hack-run-vote-query pk r-votes

    bs_ : Ballots ²
    bs_ = run-voting-phase A-voting-phase (const [])

    decryption-shares-β =
      (case β
         0: decryption-shares
         1: simulate-decryption-shares (bs_ 0₂))
      kp (bs_ β)

    bb : BB
    bb = record { Y-pk = pk ; π-pk = zk ; ballots = bs_ β ; decryption-shares = decryption-shares-β }

    exp : 𝟚
    exp = snd A-setup bb

    game = exp == β

  module Unused-simulate-decryption-shares
              (decryption-shares : Make-decryption-shares)
              (result : BB → Tally)
              (kp  : KeyPair)
              (bs_ : Ballots ²)
           where
    open KeyPair kp
    open Tallying decryption-shares result
    simulated-decryption-shares : Decryption-shares
    simulated-decryption-shares = fake-decrytion-share (tally kp (bs_ 0₂)) (bs_ 1₂) ∷ []

    {-
  module Simulated-Challenger
              (r-setup : R-setup)
              (r-votes : VoterId → R-vote ²)
              (r-adversary : R-adversary)
              (A : Adversary)
            where
    open CommonChallenger r-setup r-adversary A public
-}
  module Proof (setup : R-setup → KeyPair)
               (result : BB → Tally)
               (decryption-shares  decryption-sharesₐ : Make-decryption-shares)
               (r-setup : R-setup)
               (r-adversary : R-adversary)
               (A : Adversary)
               (r-votes : VoterId → R-vote ²)
               (simulate-decryption-shares : Simulate-decryption-shares)
               (simulate-zksecret : (pk : PublicKey) → NIZKSecretKey pk)
               where
     hack-no-queries : Hack-run-vote-query
     hack-no-queries = const id
     module EXP = Game setup decryption-shares hack-no-queries r-setup r-adversary A r-votes simulate-decryption-shares
     G₀ = EXP.exp 0₂
     G₁ = EXP.exp 1₂

     setupₐ : R-setup → KeyPair
     setupₐ r-setup = record (setup r-setup) { zk = simulate-zksecret _ }

     module EXPₐ = Game setupₐ decryption-sharesₐ hack-no-queries r-setup r-adversary A r-votes simulate-decryption-shares 0₂

     Gₐ = EXPₐ.exp

     simulate-decryption-shares-B : Make-decryption-shares
     simulate-decryption-shares-B kp bs = fake-decrytion-share t bs ∷ []
       where
         open Tallying decryption-sharesₐ result
         t  = tally kp bs

     module EXP-B = Game setupₐ simulate-decryption-shares-B hack-no-queries r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     G-B = EXP-B.exp

     hack-all-queries : Hack-run-vote-query
     hack-all-queries = const not

     Seq : ★ → ★
     Seq A = ℕ → A

     _<_ : ℕ → ℕ → 𝟚
     x < y = suc x <= y

     replicateSeq : {A : ★} → ℕ → A → A → Seq A
     replicateSeq n x y i = case (i < n) 0: x 1: y

     hack-queries-up-to : ℕ → Hack-run-vote-query
     hack-queries-up-to n i = replicateSeq (n id not i

     module EXP-C-up-to (n : ℕ) = Game setupₐ simulate-decryption-shares-B (hack-queries-up-to n) r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     module EXP-C = Game setupₐ simulate-decryption-shares-B hack-all-queries r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     G-C = EXP-C.exp

     {- EXP-C-up-to zero -}

     -- G₀∼Gₐ
-- -}
-- -}
-- -}
-- -}
-- -}


Simplified a proof.

Simplified a proof.

Ignore-this: 9a3f841d137bca087a14ef28ac6d7416

darcs-hash:20110217160257-3bd4e-34a47035e8fcc6e1f03998b1ad83625b9bd8c0ca.gz

----------------------------------------------------------------------------
-- Well-founded induction on the relation MCR
----------------------------------------------------------------------------

{-# OPTIONS --no-termination-check #-}

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module Draft.McCarthy91.WellFoundedInductionATP where

open import LTC.Base

open import Draft.McCarthy91.McCarthy91
open import Draft.McCarthy91.RelationATP

open import LTC.Data.Nat

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

-- Adapted from LTC.Data.Nat.Induction.WellFoundedI.wfInd-LT₁.
wfInd-MCR : (P : D → Set) →
            (∀ {m} → N m → (∀ {n} → N n → MCR n m → P n) → P m) →
            ∀ {n} → N n → P n
wfInd-MCR P accH Nn = accH Nn (helper Nn)
  where
    helper : ∀ {m n} → N m → N n → MCR n m → P n
    helper Nm zN 0«m = ⊥-elim (0«x→⊥ Nm 0«m)

    -- This equation does not pass the termination check.
    helper zN Nn n«0 = accH Nn
      (λ {n'} Nn' n'«n →
        let n'«0 : MCR n' zero
            n'«0 = «-trans Nn' Nn zN n'«n n«0

        in helper zN Nn' n'«0
      )

    helper (sN {m} Nm) (sN {n} Nn) Sn«Sm = helper Nm (sN Nn) Sn«m
      where
        Sn«m : MCR (succ n) m
        Sn«m = x«Sy→x«y (sN Nn) Nm Sn«Sm

----------------------------------------------------------------------------
-- Well-founded induction on the relation MCR
----------------------------------------------------------------------------

{-# OPTIONS --no-termination-check #-}

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module Draft.McCarthy91.WellFoundedInductionATP where

open import LTC.Base

open import Draft.McCarthy91.McCarthy91
open import Draft.McCarthy91.RelationATP

open import LTC.Data.Nat

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

-- Adapted from LTC.Data.Nat.Induction.WellFoundedI.wfInd-LT₁.
wfInd-MCR : (P : D → Set) →
            (∀ {m} → N m → (∀ {n} → N n → MCR n m → P n) → P m) →
            ∀ {n} → N n → P n
wfInd-MCR P accH Nn = accH Nn (helper Nn)
  where
    helper : ∀ {m n} → N m → N n → MCR n m → P n
    helper Nm zN 0«m = ⊥-elim (0«x→⊥ Nm 0«m)

    -- This equation does not pass the termination check.
    helper zN (sN Nn) Sn«0 = accH (sN Nn)
      (λ {n'} Nn' n'«Sn →
        let n'«0 : MCR n' zero
            n'«0 = «-trans Nn' (sN Nn) zN n'«Sn Sn«0

        in helper zN Nn' n'«0
      )

    helper (sN {m} Nm) (sN {n} Nn) Sn«Sm = accH (sN Nn)
      (λ {n'} Nn' n'«Sn →
        let n«m : MCR n m
            n«m = Sx«Sy→x«y Nn Nm Sn«Sm

            n'«n : MCR n' n
            n'«n = x«Sy→x«y Nn' Nn n'«Sn

            n'«m : MCR n' m
            n'«m = «-trans Nn' Nn Nm n'«n n«m

        in  helper Nm Nn' n'«m
      )


working out a few more cases for removing casts; its not quite right but more cases might help me know why

open import Nat
open import Prelude
open import core
open import contexts
open import typed-expansion
open import lemmas-gcomplete
open import lemmas-complete
open import progress-checks
open import finality
open import preservation

module cast-inert where
  -- if a term is compelete and well typed, then the casts inside are all
  -- identity casts and there are no failed casts
  cast-inert : ∀{Δ Γ d τ} →
                  Γ gcomplete →
                  d dcomplete →
                  Δ , Γ ⊢ d :: τ →
                  cast-id d -- all casts are id, and there are no failed casts
  cast-inert gc dc TAConst = CIConst
  cast-inert gc dc (TAVar x₁) = CIVar
  cast-inert gc (DCLam dc x₁) (TALam x₂ wt) = CILam (cast-inert (gcomp-extend gc x₁ x₂) dc wt)
  cast-inert gc (DCAp dc dc₁) (TAAp wt wt₁) = CIAp (cast-inert gc dc wt)
                                                   (cast-inert gc dc₁ wt₁)
  cast-inert gc () (TAEHole x x₁)
  cast-inert gc () (TANEHole x wt x₁)
  cast-inert gc (DCCast dc x x₁) (TACast wt x₂)
    with eq-complete-consist x x₁ x₂
  ... | refl = CICast (cast-inert gc dc wt)
  cast-inert gc () (TAFailedCast wt x x₁ x₂)

  -- relates expressions to the same thing with all identity casts removed
  data no-id-casts : dhexp → dhexp → Set where
    NICConst  : no-id-casts c c
    NICVar    : ∀{x} → no-id-casts (X x) (X x)
    NICLam    : ∀{x τ d d'} → no-id-casts d d' → no-id-casts (·λ x [ τ ] d) (·λ x [ τ ] d')
    NICHole   : ∀{u} → no-id-casts (⦇⦈⟨ u ⟩) (⦇⦈⟨ u ⟩)
    NICNEHole : ∀{d d' u} → no-id-casts d d' → no-id-casts (⦇ d ⦈⟨ u ⟩) (⦇ d' ⦈⟨ u ⟩)
    NICAp     : ∀{d1 d2 d1' d2'} → no-id-casts d1 d1' → no-id-casts d2 d2' → no-id-casts (d1 ∘ d2) (d1' ∘ d2')
    NICCast   : ∀{d d' τ} → no-id-casts d d' → no-id-casts (d ⟨ τ ⇒ τ ⟩) d'
    NICFailed : ∀{d d' τ1 τ2} → no-id-casts d d' → no-id-casts (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩) (d' ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  -- removing identity casts doesn't change the type
  no-id-casts-type : ∀{Γ Δ d τ d' } → Δ , Γ ⊢ d :: τ →
                                      no-id-casts d d' →
                                      Δ , Γ ⊢ d' :: τ
  no-id-casts-type TAConst NICConst = TAConst
  no-id-casts-type (TAVar x₁) NICVar = TAVar x₁
  no-id-casts-type (TALam x₁ wt) (NICLam nic) = TALam x₁ (no-id-casts-type wt nic)
  no-id-casts-type (TAAp wt wt₁) (NICAp nic nic₁) = TAAp (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁)
  no-id-casts-type (TAEHole x x₁) NICHole = TAEHole x x₁
  no-id-casts-type (TANEHole x wt x₁) (NICNEHole nic) = TANEHole x (no-id-casts-type wt nic) x₁
  no-id-casts-type (TACast wt x) (NICCast nic) = no-id-casts-type wt nic
  no-id-casts-type (TAFailedCast wt x x₁ x₂) (NICFailed nic) = TAFailedCast (no-id-casts-type wt nic) x x₁ x₂

  -- simple lemma used below; if an application is final so is each
  -- applicand. saves some redundant pattern matching.
  ap-final : ∀{d1 d2} → (d1 ∘ d2) final → d1 final × d2 final
  ap-final (FBoxed (BVVal ()))
  ap-final (FIndet (IAp x x₁ x₂)) = FIndet x₁ , x₂

  -- removing identity casts doesn't change the ultimate answer produced
  remove-casts-same : ∀{Δ d1 d2 d1' d2' Γ τ } →
                           Δ , Γ ⊢ d1 :: τ →
                           no-id-casts d1 d2 →
                           d1 ↦* d1' →
                           d2 ↦* d2' →
                           d1' final →
                           d2' final →
                           d1' == d2'
  remove-casts-same TAConst NICConst step1 step2 f1 f2 = ! (finality* (FBoxed (BVVal VConst)) step1) · finality* (FBoxed (BVVal VConst)) step2

  remove-casts-same (TAVar x₁) NICVar MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TAVar x₁) NICVar MSRefl step2 (FIndet ()) f2
  remove-casts-same (TAVar x₁) NICVar (MSStep (Step FHOuter () FHOuter) step1) step2 f1 f2

  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl MSRefl (FBoxed (BVVal VLam)) (FBoxed (BVVal VLam)) = {!!} -- ap1 (λ qq → ·λ _ [ _ ] qq) {!!}
  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl MSRefl _ (FIndet ())
  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl MSRefl (FIndet ()) _
  remove-casts-same (TALam x₁ wt) (NICLam nic) _ (MSStep x₂ step2) f1 f2 = abort (boxedval-not-step (BVVal VLam) ( _ , x₂))
  remove-casts-same (TALam x₁ wt) (NICLam nic) (MSStep x₂ step1) _ f1 f2 = abort (boxedval-not-step (BVVal VLam) ( _ , x₂))

  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) MSRefl MSRefl (FIndet (IAp x x₁ x₂)) f2 with remove-casts-same wt nic MSRefl MSRefl (FIndet x₁) (π1 (ap-final f2))
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) MSRefl MSRefl (FIndet (IAp x x₁ x₂)) f2 | refl with remove-casts-same wt₁ nic₁ MSRefl MSRefl x₂ (π2 (ap-final f2))
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) MSRefl MSRefl (FIndet (IAp x x₁ x₂)) f2 | refl | refl = refl
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) _ (MSStep x step2) (FIndet (IAp x₁ x₂ x₃)) f2 = {!!}
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) (MSStep x step1) step2 f1 f2 = {!!}

  remove-casts-same (TAEHole x x₁) NICHole MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TAEHole x x₁) NICHole MSRefl MSRefl (FIndet IEHole) (FBoxed (BVVal ()))
  remove-casts-same (TAEHole x x₁) NICHole MSRefl MSRefl (FIndet IEHole) (FIndet IEHole) = refl
  remove-casts-same (TAEHole x x₁) NICHole MSRefl (MSStep (Step FHOuter () FHOuter) step2) (FIndet IEHole) f2
  remove-casts-same (TAEHole x x₁) NICHole (MSStep (Step FHOuter () FHOuter) step1) step2 f1 f2

  remove-casts-same (TANEHole x wt x₁) (NICNEHole nic) step1 step2 f1 f2 = {!!}

  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TACast wt TCRefl) (NICCast nic) MSRefl step2 (FBoxed (BVArrCast x₁ x₂)) f2 = abort (x₁ refl)
  remove-casts-same (TACast wt (TCArr x x₁)) (NICCast nic) MSRefl step2 (FBoxed (BVArrCast x₂ x₃)) f2 = abort (x₂ refl)
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FBoxed (BVHoleCast () x₂)) f2
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FIndet (ICastArr x₁ x₂)) f2 = abort (x₁ refl)
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FIndet (ICastGroundHole () x₂)) f2
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FIndet (ICastHoleGround x₁ x₂ ())) f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep (Step FHOuter ITCastID FHOuter) step1) step2 f1 f2 = remove-casts-same wt nic step1 step2 f1 f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep (Step FHOuter (ITCastSucceed x₁) FHOuter) step1) step2 f1 f2 = remove-casts-same wt nic
                                                                                (MSStep (Step FHOuter ITCastID FHOuter) step1) step2 f1 f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep (Step FHOuter (ITCastFail x₁ () x₃) FHOuter) step1) step2 f1 f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep (Step FHOuter (ITGround ()) FHOuter) step1) step2 f1 f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep (Step FHOuter (ITExpand ()) FHOuter) step1) step2 f1 f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep (Step (FHCast x₁) x₂ (FHCast x₃)) step1) step2 f1 f2 = {!!}

    -- remove-casts-same wt nic (MSStep (Step x₁ x₂ x₃) {!!}) step2 f1 f2

  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) MSRefl MSRefl (FBoxed (BVVal ())) f2
  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) MSRefl MSRefl (FIndet (IFailedCast x₃ x₄ x₅ x₆)) (FBoxed (BVVal ()))
  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) MSRefl MSRefl (FIndet (IFailedCast x₃ x₄ x₅ x₆)) (FIndet (IFailedCast x₇ x₈ x₉ x₁₀))
    with remove-casts-same wt nic MSRefl MSRefl x₃ x₇
  ... | refl = refl
  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) MSRefl (MSStep x₃ step2) (FBoxed (BVVal ())) f2
  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) MSRefl (MSStep x₃ step2) (FIndet (IFailedCast x₄ x₅ x₆ x₇)) f2 = {!!}
  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) (MSStep x₃ step1) MSRefl f1 f2 = {!!}
  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) (MSStep x₃ step1) (MSStep x₄ step2) f1 f2 = {!!}

open import Nat
open import Prelude
open import core
open import contexts
open import typed-expansion
open import lemmas-gcomplete
open import lemmas-complete
open import progress-checks
open import finality

module cast-inert where
  -- if a term is compelete and well typed, then the casts inside are all
  -- identity casts and there are no failed casts
  cast-inert : ∀{Δ Γ d τ} →
                  Γ gcomplete →
                  d dcomplete →
                  Δ , Γ ⊢ d :: τ →
                  cast-id d
  cast-inert gc dc TAConst = CIConst
  cast-inert gc dc (TAVar x₁) = CIVar
  cast-inert gc (DCLam dc x₁) (TALam x₂ wt) = CILam (cast-inert (gcomp-extend gc x₁ x₂) dc wt)
  cast-inert gc (DCAp dc dc₁) (TAAp wt wt₁) = CIAp (cast-inert gc dc wt)
                                                   (cast-inert gc dc₁ wt₁)
  cast-inert gc () (TAEHole x x₁)
  cast-inert gc () (TANEHole x wt x₁)
  cast-inert gc (DCCast dc x x₁) (TACast wt x₂)
    with eq-complete-consist x x₁ x₂
  ... | refl = CICast (cast-inert gc dc wt)
  cast-inert gc () (TAFailedCast wt x x₁ x₂)

  -- relates expressions to the same thing with all identity casts removed
  data no-id-casts : dhexp → dhexp → Set where
    NICConst  : no-id-casts c c
    NICVar    : ∀{x} → no-id-casts (X x) (X x)
    NICLam    : ∀{x τ d d'} → no-id-casts d d' → no-id-casts (·λ x [ τ ] d) (·λ x [ τ ] d')
    NICHole   : ∀{u} → no-id-casts (⦇⦈⟨ u ⟩) (⦇⦈⟨ u ⟩)
    NICNEHole : ∀{d d' u} → no-id-casts d d' → no-id-casts (⦇ d ⦈⟨ u ⟩) (⦇ d' ⦈⟨ u ⟩)
    NICAp     : ∀{d1 d2 d1' d2'} → no-id-casts d1 d1' → no-id-casts d2 d2' → no-id-casts (d1 ∘ d2) (d1' ∘ d2')
    NICCast   : ∀{d d' τ} → no-id-casts d d' → no-id-casts (d ⟨ τ ⇒ τ ⟩) d'
    NICFailed : ∀{d d' τ1 τ2} → no-id-casts d d' → no-id-casts (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩) (d' ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  -- removing identity casts doesn't change the type
  no-id-casts-type : ∀{Γ Δ d τ d' } → Δ , Γ ⊢ d :: τ → no-id-casts d d' → Δ , Γ ⊢ d' :: τ
  no-id-casts-type TAConst NICConst = TAConst
  no-id-casts-type (TAVar x₁) NICVar = TAVar x₁
  no-id-casts-type (TALam x₁ wt) (NICLam nic) = TALam x₁ (no-id-casts-type wt nic)
  no-id-casts-type (TAAp wt wt₁) (NICAp nic nic₁) = TAAp (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁)
  no-id-casts-type (TAEHole x x₁) NICHole = TAEHole x x₁
  no-id-casts-type (TANEHole x wt x₁) (NICNEHole nic) = TANEHole x (no-id-casts-type wt nic) x₁
  no-id-casts-type (TACast wt x) (NICCast nic) = no-id-casts-type wt nic
  no-id-casts-type (TAFailedCast wt x x₁ x₂) (NICFailed nic) = TAFailedCast (no-id-casts-type wt nic) x x₁ x₂

  -- removing identity casts doesn't change the ultimate answer produced
  remove-casts-same : ∀{Δ d1 d2 d1' d2' Γ τ } →
                           Δ , Γ ⊢ d1 :: τ →
                           no-id-casts d1 d2 →
                           d1 ↦* d1' →
                           d2 ↦* d2' →
                           d1' final →
                           d2' final →
                           d1' == d2'
  remove-casts-same TAConst NICConst step1 step2 f1 f2 = ! (finality* (FBoxed (BVVal VConst)) step1) · finality* (FBoxed (BVVal VConst)) step2

  remove-casts-same (TAVar x₁) NICVar MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TAVar x₁) NICVar MSRefl step2 (FIndet ()) f2
  remove-casts-same (TAVar x₁) NICVar (MSStep (Step FHOuter () FHOuter) step1) step2 f1 f2

  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl MSRefl (FBoxed (BVVal VLam)) (FBoxed (BVVal VLam)) = {!!} -- ap1 (λ qq → ·λ _ [ _ ] qq) {!!}
  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl MSRefl _ (FIndet ())
  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl MSRefl (FIndet ()) _
  remove-casts-same (TALam x₁ wt) (NICLam nic) MSRefl (MSStep x₂ step2) f1 f2 = abort (boxedval-not-step (BVVal VLam) ( _ , x₂))
  remove-casts-same (TALam x₁ wt) (NICLam nic) (MSStep x₂ step1) MSRefl f1 f2 = abort (boxedval-not-step (BVVal VLam) ( _ , x₂))
  remove-casts-same (TALam x₁ wt) (NICLam nic) (MSStep x₂ step1) (MSStep x₃ step2) f1 f2 = {!!}

  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) MSRefl step2 (FIndet (IAp x x₁ x₂)) f2 = {!!}
  remove-casts-same (TAAp wt wt₁) (NICAp nic nic₁) (MSStep x step1) step2 f1 f2 = {!!}

  remove-casts-same (TAEHole x x₁) NICHole MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TAEHole x x₁) NICHole MSRefl MSRefl (FIndet IEHole) (FBoxed (BVVal ()))
  remove-casts-same (TAEHole x x₁) NICHole MSRefl MSRefl (FIndet IEHole) (FIndet IEHole) = refl
  remove-casts-same (TAEHole x x₁) NICHole MSRefl (MSStep (Step FHOuter () FHOuter) step2) (FIndet IEHole) f2
  remove-casts-same (TAEHole x x₁) NICHole (MSStep (Step FHOuter () FHOuter) step1) step2 f1 f2

  remove-casts-same (TANEHole x wt x₁) (NICNEHole nic) step1 step2 f1 f2 = {!!}

  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FBoxed (BVVal ())) f2
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FBoxed (BVArrCast x₁ x₂)) f2 = {!!}
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FBoxed (BVHoleCast () x₂)) f2
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FIndet (ICastArr x₁ x₂)) f2 = {!!}
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FIndet (ICastGroundHole () x₂)) f2
  remove-casts-same (TACast wt x) (NICCast nic) MSRefl step2 (FIndet (ICastHoleGround x₁ x₂ ())) f2
  remove-casts-same (TACast wt x) (NICCast nic) (MSStep x₁ step1) step2 f1 f2 = {!!}

  remove-casts-same (TAFailedCast wt x x₁ x₂) (NICFailed nic) step1 step2 f1 f2 = {!!}


Removed unnecessary import.

Removed unnecessary import.

Ignore-this: 8e1e69ee36df5076ff21e131d2de95f6

darcs-hash:20111013131446-3bd4e-e8671806671297c7debf1f8543409ea2935a3218.gz

------------------------------------------------------------------------------
-- Even predicate
------------------------------------------------------------------------------

module Draft.FOTC.Data.Nat.Even where

open import FOTC.Base

data Even : D → Set where
  zeroeven : Even zero
  nexteven : ∀ {d} → Even d → Even (succ (succ d))

indEven : (P : D → Set) →
          P zero →
          (∀ {d} → P d → P (succ (succ d))) →
          ∀ {d} → Even d → P d
indEven P P0 h zeroeven      = P0
indEven P P0 h (nexteven Ed) = h (indEven P P0 h Ed)

module Draft.FOTC.Data.Nat.Even where

open import FOTC.Base
open import FOTC.Data.Nat.Type

data Even : D → Set where
  zeroeven : Even zero
  nexteven : ∀ {d} → Even d → Even (succ (succ d))

indEven : (P : D → Set) →
          P zero →
          (∀ {d} → P d → P (succ (succ d))) →
          ∀ {d} → Even d → P d
indEven P P0 h zeroeven      = P0
indEven P P0 h (nexteven Ed) = h (indEven P P0 h Ed)


Possible agda interactive bug.

Possible agda interactive bug.

-- {-# OPTIONS --show-implicit #-}

module LinFunContructw where

open import Common
open import LinLogic
import IndexLLProp
open import LinFun
open import SetLL
open import SetLLProp

open import Relation.Binary.PropositionalEquality
open import Data.Product

open import LinFunContruct

module _ where

  open IndexLLProp

  boo : ∀{ i u ll pll ell cs} → ∀ s → (eq : complLₛ s ≡ ¬∅ cs) → (ind : IndexLL {i} {u} pll ll) → (lind : IndexLL ell ll) → ∀ ¬hob ¬hoh
        → let bind = ¬ho-shr-morph s eq ind ¬hob in
          let hind = ¬ho-shr-morph s eq lind ¬hoh in
          Orderedᵢ bind hind → Orderedᵢ ind lind
  boo ↓ () ind lind ¬hob ¬hoh ord

  boo (s ←∧) eq ↓ lind ¬hob ¬hoh ord = ⊥-elim (¬hob hitsAtLeastOnce←∧↓)
  boo (s ←∧) eq (ind ←∧) ↓ ¬hob ¬hoh ord = ⊥-elim (¬hoh hitsAtLeastOnce←∧↓)
  boo (s ←∧) eq (ind ←∧) (lind ←∧) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s
  boo (s ←∧) eq (ind ←∧) (lind ←∧) ¬hob ¬hoh ord | ∅ | [ ieq ] = ⊥-elim (¬nho (compl≡∅⇒ho s ieq ind))  where
    ¬nho : ¬ (hitsAtLeastOnce s ind)
    ¬nho x = ¬hob (hitsAtLeastOnce←∧←∧ x)
  boo (s ←∧) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (a≤ᵢb (≤ᵢ←∧ y)) | ¬∅ x | [ ieq ] with r where
   r = boo s ieq ind lind (λ z → ¬hob (hitsAtLeastOnce←∧←∧ z)) (λ z → ¬hoh (hitsAtLeastOnce←∧←∧ z)) (a≤ᵢb y)
  boo (s ←∧) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (a≤ᵢb (≤ᵢ←∧ y)) | ¬∅ x | [ ieq ] | a≤ᵢb x₁ = a≤ᵢb (≤ᵢ←∧ x₁)
  boo (s ←∧) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (a≤ᵢb (≤ᵢ←∧ y)) | ¬∅ x | [ ieq ] | b≤ᵢa x₁ = b≤ᵢa (≤ᵢ←∧ x₁)
  boo (s ←∧) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (b≤ᵢa (≤ᵢ←∧ y)) | ¬∅ x | [ ieq ] with r where
   r = boo s ieq ind lind (λ z → ¬hob (hitsAtLeastOnce←∧←∧ z)) (λ z → ¬hoh (hitsAtLeastOnce←∧←∧ z)) (b≤ᵢa y)
  boo (s ←∧) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (b≤ᵢa (≤ᵢ←∧ y)) | ¬∅ x | [ ieq ] | a≤ᵢb x₁ = a≤ᵢb (≤ᵢ←∧ x₁)
  boo (s ←∧) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (b≤ᵢa (≤ᵢ←∧ y)) | ¬∅ x | [ ieq ] | b≤ᵢa x₁ = b≤ᵢa (≤ᵢ←∧ x₁)
  boo (s ←∧) eq (ind ←∧) (∧→ lind) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s
  boo (s ←∧) eq (ind ←∧) (∧→ lind) ¬hob ¬hoh ord | ∅ | [ ieq ] = ⊥-elim (¬nho (compl≡∅⇒ho s ieq ind))  where
    ¬nho : ¬ (hitsAtLeastOnce s ind)
    ¬nho x = ¬hob (hitsAtLeastOnce←∧←∧ x)
  boo (s ←∧) refl (ind ←∧) (∧→ lind) ¬hob ¬hoh (a≤ᵢb ()) | ¬∅ x | [ ieq ]
  boo (s ←∧) refl (ind ←∧) (∧→ lind) ¬hob ¬hoh (b≤ᵢa ()) | ¬∅ x | [ ieq ]
  boo (s ←∧) eq (∧→ ind) ↓ ¬hob ¬hoh ord = ⊥-elim (¬hoh hitsAtLeastOnce←∧↓)
  boo (s ←∧) eq (∧→ ind) (lind ←∧) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s
  boo (s ←∧) eq (∧→ ind) (lind ←∧) ¬hob ¬hoh ord | ∅ | [ ieq ] = ⊥-elim (¬nho (compl≡∅⇒ho s ieq lind))  where
    ¬nho : ¬ (hitsAtLeastOnce s lind)
    ¬nho x = ¬hoh (hitsAtLeastOnce←∧←∧ x)
  boo (s ←∧) refl (∧→ ind) (lind ←∧) ¬hob ¬hoh (a≤ᵢb ()) | ¬∅ x | [ ieq ]
  boo (s ←∧) refl (∧→ ind) (lind ←∧) ¬hob ¬hoh (b≤ᵢa ()) | ¬∅ x | [ ieq ]
  boo {ll = lll ∧ rll} (s ←∧) eq (∧→ ind) (∧→ lind) ¬hob ¬hoh ord with complLₛ s
  boo {ll = lll ∧ rll} (s ←∧) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh ord | ∅ with shrink rll (fillAllLower rll) | shr-fAL-id rll
  boo {u = _} {lll ∧ rll} (s ←∧) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (a≤ᵢb x) | ∅ | .rll | refl = a≤ᵢb (≤ᵢ∧→ x)
  boo {u = _} {lll ∧ rll} (s ←∧) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (b≤ᵢa x) | ∅ | .rll | refl = b≤ᵢa (≤ᵢ∧→ x)
  boo {ll = lll ∧ rll} (s ←∧) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh ord | ¬∅ x with shrink rll (fillAllLower rll) | shr-fAL-id rll
  boo {u = _} {lll ∧ rll} (s ←∧) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (a≤ᵢb (≤ᵢ∧→ y)) | ¬∅ x | .rll | refl = a≤ᵢb (≤ᵢ∧→ y)
  boo {u = _} {lll ∧ rll} (s ←∧) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (b≤ᵢa (≤ᵢ∧→ y)) | ¬∅ x | .rll | refl = b≤ᵢa (≤ᵢ∧→ y)
  boo (∧→ s) eq ↓ lind ¬hob ¬hoh ord = ⊥-elim (¬hob hitsAtLeastOnce∧→↓)
  boo (∧→ s) eq (∧→ ind) ↓ ¬hob ¬hoh ord = ⊥-elim (¬hoh hitsAtLeastOnce∧→↓)
  boo (∧→ s) eq (∧→ ind) (∧→ lind) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s
  boo (∧→ s) eq (∧→ ind) (∧→ lind) ¬hob ¬hoh ord | ∅ | [ ieq ] = ⊥-elim (¬nho (compl≡∅⇒ho s ieq ind))  where
    ¬nho : ¬ (hitsAtLeastOnce s ind)
    ¬nho x = ¬hob (hitsAtLeastOnce∧→∧→ x)
  boo (∧→ s) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (a≤ᵢb (≤ᵢ∧→ y)) | ¬∅ x | [ ieq ] with r where
   r = boo s ieq ind lind (λ z → ¬hob (hitsAtLeastOnce∧→∧→ z)) (λ z → ¬hoh (hitsAtLeastOnce∧→∧→ z)) (a≤ᵢb y)
  boo (∧→ s) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (a≤ᵢb (≤ᵢ∧→ y)) | ¬∅ x | [ ieq ] | a≤ᵢb x₁ = a≤ᵢb (≤ᵢ∧→ x₁)
  boo (∧→ s) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (a≤ᵢb (≤ᵢ∧→ y)) | ¬∅ x | [ ieq ] | b≤ᵢa x₁ = b≤ᵢa (≤ᵢ∧→ x₁)
  boo (∧→ s) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (b≤ᵢa (≤ᵢ∧→ y)) | ¬∅ x | [ ieq ] with r where
   r = boo s ieq ind lind (λ z → ¬hob (hitsAtLeastOnce∧→∧→ z)) (λ z → ¬hoh (hitsAtLeastOnce∧→∧→ z)) (b≤ᵢa y)
  boo (∧→ s) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (b≤ᵢa (≤ᵢ∧→ y)) | ¬∅ x | [ ieq ] | a≤ᵢb x₁ = a≤ᵢb (≤ᵢ∧→ x₁)
  boo (∧→ s) refl (∧→ ind) (∧→ lind) ¬hob ¬hoh (b≤ᵢa (≤ᵢ∧→ y)) | ¬∅ x | [ ieq ] | b≤ᵢa x₁ = b≤ᵢa (≤ᵢ∧→ x₁)
  boo (∧→ s) eq (∧→ ind) (lind ←∧) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s
  boo (∧→ s) eq (∧→ ind) (lind ←∧) ¬hob ¬hoh ord | ∅ | [ ieq ] = ⊥-elim (¬nho (compl≡∅⇒ho s ieq ind))  where
    ¬nho : ¬ (hitsAtLeastOnce s ind)
    ¬nho x = ¬hob (hitsAtLeastOnce∧→∧→ x)
  boo (∧→ s) refl (∧→ ind) (lind ←∧) ¬hob ¬hoh (a≤ᵢb ()) | ¬∅ x | [ ieq ]
  boo (∧→ s) refl (∧→ ind) (lind ←∧) ¬hob ¬hoh (b≤ᵢa ()) | ¬∅ x | [ ieq ]
  boo (∧→ s) eq (ind ←∧) ↓ ¬hob ¬hoh ord = ⊥-elim (¬hoh hitsAtLeastOnce∧→↓)
  boo (∧→ s) eq (ind ←∧) (∧→ lind) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s
  boo (∧→ s) eq (ind ←∧) (∧→ lind) ¬hob ¬hoh ord | ∅ | [ ieq ] = ⊥-elim (¬nho (compl≡∅⇒ho s ieq lind))  where
    ¬nho : ¬ (hitsAtLeastOnce s lind)
    ¬nho x = ¬hoh (hitsAtLeastOnce∧→∧→ x)
  boo (∧→ s) refl (ind ←∧) (∧→ lind) ¬hob ¬hoh (a≤ᵢb ()) | ¬∅ x | [ ieq ]
  boo (∧→ s) refl (ind ←∧) (∧→ lind) ¬hob ¬hoh (b≤ᵢa ()) | ¬∅ x | [ ieq ]
  boo {ll = lll ∧ rll} (∧→ s) eq (ind ←∧) (lind ←∧) ¬hob ¬hoh ord with complLₛ s
  boo {ll = lll ∧ rll} (∧→ s) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh ord | ∅ with shrink lll (fillAllLower lll) | shr-fAL-id lll
  boo {u = _} {lll ∧ rll} (∧→ s) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (a≤ᵢb x) | ∅ | .lll | refl = a≤ᵢb (≤ᵢ←∧ x)
  boo {u = _} {lll ∧ rll} (∧→ s) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (b≤ᵢa x) | ∅ | .lll | refl = b≤ᵢa (≤ᵢ←∧ x)
  boo {ll = lll ∧ rll} (∧→ s) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh ord | ¬∅ x with shrink lll (fillAllLower lll) | shr-fAL-id lll
  boo {u = _} {lll ∧ rll} (∧→ s) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (a≤ᵢb (≤ᵢ←∧ y)) | ¬∅ x | .lll | refl = a≤ᵢb (≤ᵢ←∧ y)
  boo {u = _} {lll ∧ rll} (∧→ s) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh (b≤ᵢa (≤ᵢ←∧ y)) | ¬∅ x | .lll | refl = b≤ᵢa (≤ᵢ←∧ y)

  boo (s ←∧→ s₁) eq ↓ lind ¬hob ¬hoh ord = ⊥-elim (¬hob hitsAtLeastOnce←∧→↓)
  boo (s ←∧→ s₁) eq (ind ←∧) ↓ ¬hob ¬hoh ord = ⊥-elim (¬hoh hitsAtLeastOnce←∧→↓)
  boo (s ←∧→ s₁) eq (ind ←∧) (lind ←∧) ¬hob ¬hoh ord with complLₛ s | inspect complLₛ s | complLₛ s₁
  boo (s ←∧→ s₁) eq (ind ←∧) (lind ←∧) ¬hob ¬hoh ord | ∅ | [ ieq ] | e = ⊥-elim (¬nho (compl≡∅⇒ho s ieq ind)) where
    ¬nho : ¬ (hitsAtLeastOnce s ind)
    ¬nho x = ¬hob (hitsAtLeastOnce←∧→←∧ x)
  boo (s ←∧→ s₁) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh ord | ¬∅ x | [ ieq ] | ∅ with boo s ieq ind lind {!!} {!!} ord
  ... | g = {!!}
  boo (s ←∧→ s₁) refl (ind ←∧) (lind ←∧) ¬hob ¬hoh ord | ¬∅ x | [ ieq ] | ¬∅ x₁ = {!!}
  boo (s ←∧→ s₁) eq (ind ←∧) (∧→ lind) ¬hob ¬hoh ord = {!!}
  boo (s ←∧→ s₁) eq (∧→ ind) lind ¬hob ¬hoh ord = {!!}

  boo (s ←∨) eq ind lind ¬hob ¬hoh ord = {!!}
  boo (∨→ s) eq ind lind ¬hob ¬hoh ord = {!!}
  boo (s ←∨→ s₁) eq ind lind ¬hob ¬hoh ord = {!!}
  boo (s ←∂) eq ind lind ¬hob ¬hoh ord = {!!}
  boo (∂→ s) eq ind lind ¬hob ¬hoh ord = {!!}
  boo (s ←∂→ s₁) eq ind lind ¬hob ¬hoh ord = {!!}

  private
    data M¬ho {i u ll n dt df} (s : SetLL ll) : MIndexLL (τ {i} {u} {n} {dt} df) ll → Set where
      ∅ : M¬ho s ∅
      ¬∅ : {ind : IndexLL (τ {i} {u} {n} {dt} df) ll} → (¬ho : ¬ (hitsAtLeastOnce s ind))
           → M¬ho s (¬∅ ind)

    hf : ∀{i u n dt df} → ∀ ll → ∀{cs} → (ind : MIndexLL (τ {i} {u} {n} {dt} df) ll)
         → (s : SetLL ll) → (ceq : complLₛ s ≡ ¬∅ cs) → (m¬ho : M¬ho s ind) → LinLogic i {u}
         → LinLogic i {u}
    hf ll {cs} ∅ s ceq mnho cll = shrinkcms ll s cs ceq
    hf ll {cs} (¬∅ x) s ceq (¬∅ ¬ho) cll = replLL (shrinkcms ll s cs ceq) (¬ho-shr-morph s ceq x ¬ho) cll

    hf2 : ∀{i u ll rll n dt df ts} → (ind : MIndexLL (τ {i} {u} {n} {dt} df) ll)
          → (s : SetLL ll) → (m¬ho : M¬ho s ind) → (lf : LFun {i} {u} ll rll)
          → ¬∅ ts ≡ tranLFMSetLL lf (¬∅ s)
          → M¬ho ts (tranLFMIndexLL lf ind)
    hf2 ∅ mnho s lf eqs = ∅
    hf2 (¬∅ x) s mnho lf eqs with tranLFMIndexLL lf (¬∅ x) | inspect (λ z → tranLFMIndexLL lf (¬∅ z)) x
    hf2 (¬∅ x) s mnho lf eqs | ∅ | [ eq ] = ∅
    hf2 (¬∅ x) s (¬∅ ¬ho) lf eqs | ¬∅ _ | [ eq ] = ¬∅ (tranLF-preserves-¬ho lf x s ¬ho (sym eq) eqs)

  data MLFun {i u ll rll n dt df} (mind : MIndexLL (τ {i} {u} {n} {dt} df) ll)
             (s : SetLL ll) (m¬ho : M¬ho s mind) (lf : LFun {i} {u} ll rll) : Set (lsuc u) where
    ∅ : ∀{ts} → (∅ ≡ mind) → (complLₛ s ≡ ∅)
        → (eqs : ¬∅ ts ≡ tranLFMSetLL lf (¬∅ s)) → (ceqo : complLₛ ts ≡ ∅) → MLFun mind s m¬ho lf
    ¬∅∅ : ∀ {ind cs} → (¬∅ ind ≡ mind) → (ceqi : complLₛ s ≡ ¬∅ cs)
          → (eqs : ∅ ≡ tranLFMSetLL lf (¬∅ s))
          → (cll : LinLogic i {u}) → LFun (hf ll mind s ceqi m¬ho cll) rll
          → MLFun mind s m¬ho lf
    ¬∅¬∅ : ∀ {cs ts cts} → (ceqi : complLₛ s ≡ ¬∅ cs)
           → let tind = tranLFMIndexLL lf mind in
           (eqs : ¬∅ ts ≡ tranLFMSetLL lf (¬∅ s)) → (ceqo : complLₛ ts ≡ ¬∅ cts)
           → ((cll : LinLogic i {u}) → LFun (hf ll mind s ceqi m¬ho cll) (hf rll tind ts ceqo (hf2 mind s m¬ho lf eqs) cll))
           → MLFun mind s m¬ho lf
           --???  We will never reach to a point where complLₛ ts ≡ ∅ because
           -- the input would have the same fate. ( s becomes smaller as we go forward, thus complLₛ increases. Here we take the case where s is not ∅.
           -- Correction : In fact , the ordinal remains the same since all the points of the set need to to end at the same com by design. (but we might not be able to prove this now and thus need to go with the weaker argument.)

-- s is special, all of the input points eventually will be consumed by a single com + the point from the index. Thus if complLₛ s ≡ ∅, this means that lf does not contain coms or calls.
-- Maybe one day, we will provide a datatype that contains that information, for the time being, we use IMPOSSIBLE where necessary.

    -- s here does contain the ind.
  -- TODO IMPORTANT After test , we need to remove ⊂ that contain I in the first place.
  test : ∀{i u rll ll n dt df} → (ind : MIndexLL (τ {i} {u} {n} {dt} df) ll) → (s : SetLL ll)
         → ∀ m¬ho → (lf : LFun ll rll) → MLFun ind s m¬ho lf
  test ind s mnho lf with complLₛ s | inspect complLₛ s
  test ∅ s ∅ lf | ∅ | [ e ] with tranLFMSetLL lf (¬∅ s) | inspect (λ z → tranLFMSetLL lf (¬∅ z)) s
  test ∅ s ∅ lf | ∅ | [ e ] | ∅ | [ r ] = IMPOSSIBLE
  test ∅ s ∅ lf | ∅ | [ e ] | ¬∅ x | [ r ] with complLₛ x | inspect complLₛ x
  test ∅ s ∅ lf | ∅ | [ e ] | ¬∅ x | [ r ] | ∅ | [ t ] = ∅ refl e (sym r) t
  test ∅ s ∅ lf | ∅ | [ e ] | ¬∅ x | [ r ] | ¬∅ x₁ | t = IMPOSSIBLE
  test (¬∅ x) s (¬∅ ¬ho) lf | ∅ | [ e ] = ⊥-elim (¬ho (compl≡∅⇒ho s e x))

  test ∅ s mnho I | ¬∅ x | [ eq ] = ¬∅¬∅ eq refl eq (λ cll → I)
  test (¬∅ x₁) s (¬∅ ¬ho) I | ¬∅ x | [ eq ] = ¬∅¬∅ eq refl eq (λ cll → I)

  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] with truncSetLL s lind | inspect (truncSetLL s) lind
  ... | ∅ | [ teq ] with (mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at z) lind
  ... | ∅ | [ meq ] = ⊥-elim ((trunc≡∅⇒¬mrpls≡∅ s lind teq) meq)
  ... | ¬∅ mx | [ meq ] with test {n = n} {dt} {df} ∅ mx ∅ lf₁
  ... | ∅ indeq ceq eqs ceqo = ⊥-elim ((del⇒¬ho s lind (sym meq)) (compl≡∅⇒ho mx ceq (a≤ᵢb-morph lind lind ell (≤ᵢ-reflexive lind))))
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | ¬∅∅ () ceqi eqs cll t
  ... | ¬∅¬∅ {ts = ts} {cts} ceqi eqs ceqo t = ¬∅¬∅ eq tseq ceqo ((λ z → _⊂_ {ind = ¬ho-shr-morph s eq lind (trunc≡∅⇒¬ho s lind teq)} lf (g (t z)))) where
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs))
    g = subst (λ a → LFun a (shrink rll cts)) (shrink-repl-comm s lind eq teq meq ceqi)
  test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] with test {n = n} {dt} {df} ∅ trs ∅ lf
  ... | ∅ indeq ceq eqs ceqo with (mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at z) lind
  ... | ¬∅ mx | r with test {n = n} {dt} {df} ∅ mx ∅ lf₁
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ∅ indeq1 ceq1 eqs1 ceqo1 with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ∅ indeq1 ceq1 eqs1 ceqo1 | ∅ = IMPOSSIBLE -- IMPOSSIBLE and not provable with the current information we have.
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ∅ indeq1 ceq1 eqs1 ceqo1 | ¬∅ x with compl≡¬∅⇒replace-compl≡¬∅ s lind eq teq ceq x
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ .(replacePartOf s to x at ind) | [ refl ] | ∅ indeq1 ceq1 eqs1 ceqo1 | ¬∅ x | proj₃ , proj₄ with complLₛ (replacePartOf s to x at ind)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ .(replacePartOf s to x at ind) | [ refl ] | ∅ indeq1 refl eqs1 ceqo1 | ¬∅ x | proj₃ , () | .∅
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ¬∅∅ () ceqi1 eqs1 cll1 t1
  test {rll = rll} {ll = ll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ {ts = ts} indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ¬∅¬∅ {cs} ceqi1 eqs1 ceqo1 t1
    = ¬∅¬∅ eq tseq ceqo1 ((λ cll → subst (λ z → LFun z (shrink rll _)) (shrink-repl≡∅ s lind eq teq ceq _ ceqo t) (t1 cll))) where
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs1))
    t : complLₛ (replacePartOf s to ts at lind) ≡ ¬∅ cs
    t with trans (cong (λ z → mreplacePartOf ¬∅ s to z at lind) eqs) meq
    ... | g with replacePartOf s to ts at lind
    t | refl | e = ceqi1
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ∅ | [ meq ] with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq refl ceqo | ∅ | [ () ] | .(¬∅ _)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind₁} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅∅ () ceqi eqs cll t
  test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t
       with (mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at z) lind
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ∅ | [ meq ] with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi () ceqo t | ∅ | [ meq ] | ∅
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ∅ | [ () ] | ¬∅ _
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] with test {n = n} {dt} {df} ∅ mx ∅ lf₁
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] | ∅ indeq ceq1 eqs1 ceqo1 with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {ll = ll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ {ts = ts} ceqi refl ceqo t | ¬∅ .(replacePartOf s to _ at lind) | [ refl ] | ∅ indeq1 ceq1 eqs1 ceqo1 | .(¬∅ _) with complLₛ ts | ct where
    m = replacePartOf s to ts at lind
    mind = subst (λ z → IndexLL z (replLL ll lind ell)) (replLL-↓ lind) ((a≤ᵢb-morph lind lind ell (≤ᵢ-reflexive lind)))
    ct = compl≡∅⇒compltr≡∅ m ceq1 mind (sym (tr-repl⇒id s lind ts))
  test {rll = rll} {ll} {n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ {ts = ts} ceqi refl () t | ¬∅ .(replacePartOf s to ts at ind) | [ refl ] | ∅ indeq ceq1 eqs1 ceqo1 | .(¬∅ ts) | .∅ | refl
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] | ¬∅∅ () ceqi₁ eqs₁ cll1 x₁
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] | ¬∅¬∅ ceqi1 eqs1 ceqo1 t1
      = ¬∅¬∅ eq tseq ceqo1 (λ cll → _⊂_ {ind = hind} (t cll) (subst (λ z → LFun z _) (sym (ho-shrink-repl-comm s lind eq teq ceqi ceqo w ceqi1)) (t1 cll))) where
    w = trans (cong (λ z → mreplacePartOf ¬∅ s to z at lind) eqs) meq
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs1))
    hind = ho-shr-morph s eq lind (sym teq) ceqi
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] with truncSetLL s lind | inspect (truncSetLL s) lind
  ... | ∅ | [ teq ] with (mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at z) lind
  ... | ∅ | [ meq ] = ⊥-elim ((trunc≡∅⇒¬mrpls≡∅ s lind teq) meq)
  ... | ¬∅ mx | [ meq ] with isLTi lind ind
  ... | no ¬p with test {n = n} {dt} {df} nind mx (¬∅ n¬ho) lf₁ where
    nord = indτ&¬ge⇒¬Ord ind lind ¬p
    nind = ¬∅ (¬ord-morph ind lind ell (flipNotOrdᵢ nord))
    n¬ho = ¬ord&¬ho-del⇒¬ho ind s ¬ho lind nord (sym meq)
  ... | ∅ () ceq eqs ceqo
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | no ¬p | ¬∅∅ {ind = tind} indeq ceqi eqs cll t
    = ¬∅∅ refl eq tseq cll (_⊂_ {ind = sind} lf {!best!}) where
    nord = indτ&¬ge⇒¬Ord ind lind ¬p
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs))
    hind = ¬ho-shr-morph s eq lind ((trunc≡∅⇒¬ho s lind teq))
    bind = ¬ho-shr-morph s eq ind ¬ho
    sind = ¬ord-morph hind bind cll {!!}
    best = replLL-¬ordab≡ba bind cll hind ell {!!}

    find = ¬ord-morph ind lind ell (flipNotOrdᵢ nord)
    nind = ¬ord-morph lind ind cll nord
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | no ¬p | ¬∅¬∅ ceqi eqs ceqo t = {!!}
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | yes p = {!!}
  test (¬∅ ind₁) s (¬∅ ¬ho) (_⊂_ {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] = {!!}
  test ind s mnho (tr ltr lf) | ¬∅ x | eq = {!!}
  test ind s mnho (com df₁ lf) | ¬∅ x | eq = {!!}
  test ind s mnho (call x₁) | ¬∅ x | eq = {!!}

--  test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] with tranLFMSetLL lf (¬∅ trs) | inspect (λ z → tranLFMSetLL lf (¬∅ z)) trs | test {n = n} {dt} {df} ∅ trs ∅ lf
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ tseq ] | I x eqs ceqo with tranLFMSetLL lf (¬∅ trs)
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ refl ] | I x () ceqo | .∅
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | tseq | ¬I∅ ceqi eqs x = {!!}
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ tseq ] | ¬I¬∅ ceqi eqs ceqo x with tranLFMSetLL lf (¬∅ trs)
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ refl ] | ¬I¬∅ ceqi () ceqo x | .(¬∅ _)
--
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ¬∅ ts | tseq | I x eqs ceqo = {!!}
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ¬∅ ts | tseq | ¬I∅ ceqi eqs x = {!!}
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ¬∅ ts | tseq | ¬I¬∅ ceqi eqs ceqo x = {!!}
--
--
---- with test {n = n} {dt} {df} ∅ trs ∅ lf
----   ... | I ceq with mreplacePartOf (¬∅ s) to tlf at lind | inspect (λ z → mreplacePartOf (¬∅ s) to tlf at z) lind where -- tranLFMSetLL lf₁ nmx | inspect (tranLFMSetLL lf₁) nmx | test ∅ {!nmx!} ∅ lf₁ where
----     tlf = tranLFMSetLL lf (¬∅ trs)
---- --    is = test ∅ {!!} ∅ lf₁
----   ... | ∅ | [ meq ] = IMPOSSIBLE -- Since we have I, lf cannot contain com or call, thus tlf is not ∅.
----   ... | ¬∅ mx | [ meq ] with test {n = n} {dt} {df} ∅ mx ∅ lf₁
----   ... | I ceq1 = IMPOSSIBLE -- TODO This is impossible because eq assures us that complLₛ s ≡ ¬∅ x but complLₛ of both ceq and ceq1 are ∅.
----   ... | ¬I∅ ceqi1 eqs1 t1 = ¬I∅ eq tseq {!!} where
----     meeq = subst (λ z → (mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) ≡ ¬∅ mx) (sym teq) meq
----     tseq = subst (λ z → ∅ ≡ tranLFMSetLL lf₁ z) (sym meeq) eqs1
----   ... | ¬I¬∅ ceqi1 eqs1 ceqo1 t1 = {!!}
----   test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬I∅ ceqi eqs q = {!!}
----   test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬I¬∅ ceqi eqs ceqo q = {!!} where
--  test ∅ s ∅ (tr ltr lf) | ¬∅ x | [ eq ] = {!!}
--  test ∅ s ∅ (com df₁ lf) | ¬∅ x | [ eq ] = IMPOSSIBLE -- Since ind is ∅, this is impossible.
--  test ∅ s ∅ (call x₁) | ¬∅ x | [ eq ] = IMPOSSIBLE
--  test (¬∅ x) s (¬∅ ¬ho) lf = {!!}
--
--

-- {-# OPTIONS --show-implicit #-}

module LinFunContructw where

open import Common
open import LinLogic
import IndexLLProp
open import LinFun
open import SetLL
open import SetLLProp

open import Relation.Binary.PropositionalEquality
open import Data.Product

open import LinFunContruct

module _ where

  open IndexLLProp

  private
    data M¬ho {i u ll n dt df} (s : SetLL ll) : MIndexLL (τ {i} {u} {n} {dt} df) ll → Set where
      ∅ : M¬ho s ∅
      ¬∅ : {ind : IndexLL (τ {i} {u} {n} {dt} df) ll} → (¬ho : ¬ (hitsAtLeastOnce s ind))
           → M¬ho s (¬∅ ind)

    hf : ∀{i u n dt df} → ∀ ll → ∀{cs} → (ind : MIndexLL (τ {i} {u} {n} {dt} df) ll)
         → (s : SetLL ll) → (ceq : complLₛ s ≡ ¬∅ cs) → (m¬ho : M¬ho s ind) → LinLogic i {u}
         → LinLogic i {u}
    hf ll {cs} ∅ s ceq mnho cll = shrinkcms ll s cs ceq
    hf ll {cs} (¬∅ x) s ceq (¬∅ ¬ho) cll = replLL (shrinkcms ll s cs ceq) (¬ho-shr-morph s ceq x ¬ho) cll

    hf2 : ∀{i u ll rll n dt df ts} → (ind : MIndexLL (τ {i} {u} {n} {dt} df) ll)
          → (s : SetLL ll) → (m¬ho : M¬ho s ind) → (lf : LFun {i} {u} ll rll)
          → ¬∅ ts ≡ tranLFMSetLL lf (¬∅ s)
          → M¬ho ts (tranLFMIndexLL lf ind)
    hf2 ∅ mnho s lf eqs = ∅
    hf2 (¬∅ x) s mnho lf eqs with tranLFMIndexLL lf (¬∅ x) | inspect (λ z → tranLFMIndexLL lf (¬∅ z)) x
    hf2 (¬∅ x) s mnho lf eqs | ∅ | [ eq ] = ∅
    hf2 (¬∅ x) s (¬∅ ¬ho) lf eqs | ¬∅ _ | [ eq ] = ¬∅ (tranLF-preserves-¬ho lf x s ¬ho (sym eq) eqs)

  data MLFun {i u ll rll n dt df} (mind : MIndexLL (τ {i} {u} {n} {dt} df) ll)
             (s : SetLL ll) (m¬ho : M¬ho s mind) (lf : LFun {i} {u} ll rll) : Set (lsuc u) where
    ∅ : ∀{ts} → (∅ ≡ mind) → (complLₛ s ≡ ∅)
        → (eqs : ¬∅ ts ≡ tranLFMSetLL lf (¬∅ s)) → (ceqo : complLₛ ts ≡ ∅) → MLFun mind s m¬ho lf
    ¬∅∅ : ∀ {ind cs} → (¬∅ ind ≡ mind) → (ceqi : complLₛ s ≡ ¬∅ cs)
          → (eqs : ∅ ≡ tranLFMSetLL lf (¬∅ s))
          → ((cll : LinLogic i {u}) → LFun (hf ll mind s ceqi m¬ho cll) rll)
          → MLFun mind s m¬ho lf
    ¬∅¬∅ : ∀ {cs ts cts} → (ceqi : complLₛ s ≡ ¬∅ cs)
           → let tind = tranLFMIndexLL lf mind in
           (eqs : ¬∅ ts ≡ tranLFMSetLL lf (¬∅ s)) → (ceqo : complLₛ ts ≡ ¬∅ cts)
           → ((cll : LinLogic i {u}) → LFun (hf ll mind s ceqi m¬ho cll) (hf rll tind ts ceqo (hf2 mind s m¬ho lf eqs) cll))
           → MLFun mind s m¬ho lf
           --???  We will never reach to a point where complLₛ ts ≡ ∅ because
           -- the input would have the same fate. ( s becomes smaller as we go forward, thus complLₛ increases. Here we take the case where s is not ∅.
           -- Correction : In fact , the ordinal remains the same since all the points of the set need to to end at the same com by design. (but we might not be able to prove this now and thus need to go with the weaker argument.)

-- s is special, all of the input points eventually will be consumed by a single com + the point from the index. Thus if complLₛ s ≡ ∅, this means that lf does not contain coms or calls.
-- Maybe one day, we will provide a datatype that contains that information, for the time being, we use IMPOSSIBLE where necessary.

    -- s here does contain the ind.
  -- TODO IMPORTANT After test , we need to remove ⊂ that contain I in the first place.
  test : ∀{i u rll ll n dt df} → (ind : MIndexLL (τ {i} {u} {n} {dt} df) ll) → (s : SetLL ll)
         → ∀ m¬ho → (lf : LFun ll rll) → MLFun ind s m¬ho lf
  test ind s mnho lf with complLₛ s | inspect complLₛ s
  test ∅ s ∅ lf | ∅ | [ e ] with tranLFMSetLL lf (¬∅ s) | inspect (λ z → tranLFMSetLL lf (¬∅ z)) s
  test ∅ s ∅ lf | ∅ | [ e ] | ∅ | [ r ] = IMPOSSIBLE
  test ∅ s ∅ lf | ∅ | [ e ] | ¬∅ x | [ r ] with complLₛ x | inspect complLₛ x
  test ∅ s ∅ lf | ∅ | [ e ] | ¬∅ x | [ r ] | ∅ | [ t ] = ∅ {!!} e (sym r) t
  test ∅ s ∅ lf | ∅ | [ e ] | ¬∅ x | [ r ] | ¬∅ x₁ | t = IMPOSSIBLE
  test (¬∅ x) s (¬∅ ¬ho) lf | ∅ | [ e ] = ⊥-elim (¬ho (compl≡∅⇒ho s e x))

  test ∅ s mnho I | ¬∅ x | [ eq ] = ¬∅¬∅ eq refl eq (λ cll → I)
  test (¬∅ x₁) s (¬∅ ¬ho) I | ¬∅ x | [ eq ] = ¬∅¬∅ eq refl eq (λ cll → I)

  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] with truncSetLL s lind | inspect (truncSetLL s) lind
  ... | ∅ | [ teq ] with (mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at z) lind
  ... | ∅ | [ meq ] = ⊥-elim ((trunc≡∅⇒¬mrpls≡∅ s lind teq) meq)
  ... | ¬∅ mx | [ meq ] with test {n = n} {dt} {df} ∅ mx ∅ lf₁
  ... | ∅ indeq ceq eqs ceqo = ⊥-elim ((del⇒¬ho s lind (sym meq)) (compl≡∅⇒ho mx ceq (a≤ᵢb-morph lind lind ell (≤ᵢ-reflexive lind))))
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | ¬∅∅ () ceqi eqs t
  ... | ¬∅¬∅ {ts = ts} {cts} ceqi eqs ceqo t = ¬∅¬∅ eq tseq ceqo ((λ z → _⊂_ {ind = ¬ho-shr-morph s eq lind (trunc≡∅⇒¬ho s lind teq)} lf (g (t z)))) where
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs))
    g = subst (λ a → LFun a (shrink rll cts)) (shrink-repl-comm s lind eq teq meq ceqi)
  test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] with test {n = n} {dt} {df} ∅ trs ∅ lf
  ... | ∅ indeq ceq eqs ceqo with (mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at z) lind
  ... | ¬∅ mx | r with test {n = n} {dt} {df} ∅ mx ∅ lf₁
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ∅ indeq1 ceq1 eqs1 ceqo1 with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ∅ indeq1 ceq1 eqs1 ceqo1 | ∅ = IMPOSSIBLE -- IMPOSSIBLE and not provable with the current information we have.
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ∅ indeq1 ceq1 eqs1 ceqo1 | ¬∅ x with compl≡¬∅⇒replace-compl≡¬∅ s lind eq teq ceq x
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ .(replacePartOf s to x at ind) | [ refl ] | ∅ indeq1 ceq1 eqs1 ceqo1 | ¬∅ x | proj₃ , proj₄ with complLₛ (replacePartOf s to x at ind)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ .(replacePartOf s to x at ind) | [ refl ] | ∅ indeq1 refl eqs1 ceqo1 | ¬∅ x | proj₃ , () | .∅
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ¬∅∅ () ceqi1 eqs1 t1
  test {rll = rll} {ll = ll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ {ts = ts} indeq ceq eqs ceqo | ¬∅ mx | [ meq ] | ¬∅¬∅ {cs} ceqi1 eqs1 ceqo1 t1
    = ¬∅¬∅ eq tseq ceqo1 ((λ cll → subst (λ z → LFun z (shrink rll _)) (shrink-repl≡∅ s lind eq teq ceq _ ceqo t) (t1 cll))) where
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs1))
    t : complLₛ (replacePartOf s to ts at lind) ≡ ¬∅ cs
    t with trans (cong (λ z → mreplacePartOf ¬∅ s to z at lind) eqs) meq
    ... | g with replacePartOf s to ts at lind
    t | refl | e = ceqi1
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq eqs ceqo | ∅ | [ meq ] with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ∅ indeq ceq refl ceqo | ∅ | [ () ] | .(¬∅ _)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind₁} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅∅ () ceqi eqs t
  test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t
       with (mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (tranLFMSetLL lf (¬∅ trs)) at z) lind
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ∅ | [ meq ] with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi () ceqo t | ∅ | [ meq ] | ∅
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ∅ | [ () ] | ¬∅ _
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] with test {n = n} {dt} {df} ∅ mx ∅ lf₁
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] | ∅ indeq ceq1 eqs1 ceqo1 with tranLFMSetLL lf (¬∅ trs)
  test {rll = rll} {ll = ll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ {ts = ts} ceqi refl ceqo t | ¬∅ .(replacePartOf s to _ at lind) | [ refl ] | ∅ indeq1 ceq1 eqs1 ceqo1 | .(¬∅ _) with complLₛ ts | ct where
    m = replacePartOf s to ts at lind
    mind = subst (λ z → IndexLL z (replLL ll lind ell)) (replLL-↓ lind) ((a≤ᵢb-morph lind lind ell (≤ᵢ-reflexive lind)))
    ct = compl≡∅⇒compltr≡∅ m ceq1 mind (sym (tr-repl⇒id s lind ts))
  test {rll = rll} {ll} {n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ {ts = ts} ceqi refl () t | ¬∅ .(replacePartOf s to ts at ind) | [ refl ] | ∅ indeq ceq1 eqs1 ceqo1 | .(¬∅ ts) | .∅ | refl
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] | ¬∅∅ () ceqi₁ eqs₁ x₁
  test {rll = rll} {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬∅¬∅ ceqi eqs ceqo t | ¬∅ mx | [ meq ] | ¬∅¬∅ ceqi1 eqs1 ceqo1 t1
      = ¬∅¬∅ eq tseq ceqo1 (λ cll → _⊂_ {ind = hind} (t cll) (subst (λ z → LFun z _) (sym (ho-shrink-repl-comm s lind eq teq ceqi ceqo w ceqi1)) (t1 cll))) where
    w = trans (cong (λ z → mreplacePartOf ¬∅ s to z at lind) eqs) meq
    tseq =  sym (trans (cong (λ z → tranLFMSetLL lf₁ z) (trans (cong (λ z → mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) teq) meq)) (sym eqs1))
    hind = ho-shr-morph s eq lind (sym teq) ceqi
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] with truncSetLL s lind | inspect (truncSetLL s) lind
  ... | ∅ | [ teq ] with (mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at lind) | inspect (λ z → mreplacePartOf (¬∅ s) to (∅ {ll = ell}) at z) lind
  ... | ∅ | [ meq ] = ⊥-elim ((trunc≡∅⇒¬mrpls≡∅ s lind teq) meq)
  ... | ¬∅ mx | [ meq ] with isLTi lind ind
  ... | no ¬p with test {n = n} {dt} {df} nind mx (¬∅ n¬ho) lf₁ where
    nord = indτ&¬ge⇒¬Ord ind lind ¬p
    nind = ¬∅ (¬ord-morph ind lind ell (flipNotOrdᵢ nord))
    n¬ho = ¬ord&¬ho-del⇒¬ho ind s ¬ho lind nord (sym meq)
  ... | ∅ () ceq eqs ceqo
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind₁) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | no ¬p | ¬∅∅ refl ceqi eqs t = {!!}
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind₁) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | no ¬p | ¬∅¬∅ ceqi eqs ceqo t = {!!}
  test {rll = rll} {n = n} {dt} {df} (¬∅ ind) s (¬∅ ¬ho) (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ∅ | [ teq ] | ¬∅ mx | [ meq ] | yes p = {!!}
  test (¬∅ ind₁) s (¬∅ ¬ho) (_⊂_ {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] = {!!}
  test ind s mnho (tr ltr lf) | ¬∅ x | eq = {!!}
  test ind s mnho (com df₁ lf) | ¬∅ x | eq = {!!}
  test ind s mnho (call x₁) | ¬∅ x | eq = {!!}

--  test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] with tranLFMSetLL lf (¬∅ trs) | inspect (λ z → tranLFMSetLL lf (¬∅ z)) trs | test {n = n} {dt} {df} ∅ trs ∅ lf
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ tseq ] | I x eqs ceqo with tranLFMSetLL lf (¬∅ trs)
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ refl ] | I x () ceqo | .∅
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | tseq | ¬I∅ ceqi eqs x = {!!}
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ tseq ] | ¬I¬∅ ceqi eqs ceqo x with tranLFMSetLL lf (¬∅ trs)
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ∅ | [ refl ] | ¬I¬∅ ceqi () ceqo x | .(¬∅ _)
--
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ¬∅ ts | tseq | I x eqs ceqo = {!!}
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ¬∅ ts | tseq | ¬I∅ ceqi eqs x = {!!}
--  test ∅ s ∅ (_⊂_ {ell = ell} {ind = ind} lf lf₁) | ¬∅ x₁ | [ eq ] | ¬∅ trs | [ teq ] | ¬∅ ts | tseq | ¬I¬∅ ceqi eqs ceqo x = {!!}
--
--
---- with test {n = n} {dt} {df} ∅ trs ∅ lf
----   ... | I ceq with mreplacePartOf (¬∅ s) to tlf at lind | inspect (λ z → mreplacePartOf (¬∅ s) to tlf at z) lind where -- tranLFMSetLL lf₁ nmx | inspect (tranLFMSetLL lf₁) nmx | test ∅ {!nmx!} ∅ lf₁ where
----     tlf = tranLFMSetLL lf (¬∅ trs)
---- --    is = test ∅ {!!} ∅ lf₁
----   ... | ∅ | [ meq ] = IMPOSSIBLE -- Since we have I, lf cannot contain com or call, thus tlf is not ∅.
----   ... | ¬∅ mx | [ meq ] with test {n = n} {dt} {df} ∅ mx ∅ lf₁
----   ... | I ceq1 = IMPOSSIBLE -- TODO This is impossible because eq assures us that complLₛ s ≡ ¬∅ x but complLₛ of both ceq and ceq1 are ∅.
----   ... | ¬I∅ ceqi1 eqs1 t1 = ¬I∅ eq tseq {!!} where
----     meeq = subst (λ z → (mreplacePartOf ¬∅ s to tranLFMSetLL lf z at lind) ≡ ¬∅ mx) (sym teq) meq
----     tseq = subst (λ z → ∅ ≡ tranLFMSetLL lf₁ z) (sym meeq) eqs1
----   ... | ¬I¬∅ ceqi1 eqs1 ceqo1 t1 = {!!}
----   test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬I∅ ceqi eqs q = {!!}
----   test {n = n} {dt} {df} ∅ s ∅ (_⊂_ {ell = ell} {ind = lind} lf lf₁) | ¬∅ x | [ eq ] | ¬∅ trs | [ teq ] | ¬I¬∅ ceqi eqs ceqo q = {!!} where
--  test ∅ s ∅ (tr ltr lf) | ¬∅ x | [ eq ] = {!!}
--  test ∅ s ∅ (com df₁ lf) | ¬∅ x | [ eq ] = IMPOSSIBLE -- Since ind is ∅, this is impossible.
--  test ∅ s ∅ (call x₁) | ¬∅ x | [ eq ] = IMPOSSIBLE
--  test (¬∅ x) s (¬∅ ¬ho) lf = {!!}
--
--


More regular names for validity for type

Match validity for contexts.

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive
open import Data.Empty

[_]τ_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

-- This can't be a datatype, since it wouldn't be strictly positive as it
-- appears on the left of an arrow in the function case, which then can be
-- contained in nested "fromto-validity" proofs.
sumfromto : ∀ (σ τ : Type) → (dv : SumChange2 {A = ⟦ σ ⟧Type} {B = ⟦ τ ⟧Type}) → (v1 v2 : ⟦ sum σ τ ⟧Type) → Set
sumfromto σ τ (ch₁ da) (inj₁ a1) (inj₁ a2) = [ σ ]τ da from a1 to a2
-- These fallback equations unfortunately don't hold definitionally, they're
-- split on multiple cases, so the pattern match is a mess.
--
-- To "case split" on validity, I typically copy-paste the pattern match from
-- fromto→⊕ and change the function name :-(.
sumfromto σ τ (ch₁ da) _ _ = ⊥
sumfromto σ τ (ch₂ db) (inj₂ b1) (inj₂ b2) = [ τ ]τ db from b1 to b2
sumfromto σ τ (ch₂ db) _ _ = ⊥
sumfromto σ τ (rp (inj₂ b2)) (inj₁ a1) (inj₂ b2') = b2 ≡ b2'
sumfromto σ τ (rp (inj₁ a2)) (inj₂ b1) (inj₁ a2') = a2 ≡ a2'
sumfromto σ τ (rp s) _ _ = ⊥

[ σ ⇒ τ ]τ df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ]τ da from a1 to a2 → [ τ ]τ df a1 da from f1 a1 to f2 a2
[ int ]τ dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ]τ (da , db) from (a1 , b1) to (a2 , b2) = [ σ ]τ da from a1 to a2 × [ τ ]τ db from b1 to b2
[ sum σ τ ]τ dv from v1 to v2 = sumfromto σ τ (convert dv) v1 v2

data [_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ]τ dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ]τ v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₁ a2) = ⊝-fromto a1 a2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₂ b2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₁ a2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₂ b2) = ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ]τ nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa rewrite fromto→⊕ da a1 a2 daa = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb rewrite fromto→⊕ db b1 b2 dbb = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveConst : ∀ {τ} c →
  [ τ ]τ ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst (lit n) = sym (right-id-int n)
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = daa
fromtoDeriveConst rinj db b1 b2 dbb = dbb
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa df f1 f2 dff dg g1 g2 dgg = dff da a1 a2 daa
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb df f1 f2 dff dg g1 g2 dgg = dgg db b1 b2 dbb
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

open import Postulate.Extensionality

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ]τ da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ]τ da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ]τ da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da _ _ daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ]τ dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ]τ dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa = sv₁ a1 da (fromto→valid da a1 a2 daa)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb = sv₂ b1 db (fromto→valid db b1 b2 dbb)
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = svrp₂ b1 a2
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = svrp₁ a1 b2
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ]τ df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)
valid→fromto {sum σ τ} .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) = valid→fromto a da ada
valid→fromto {sum σ τ} .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) = valid→fromto b db bdb
valid→fromto {sum σ τ} .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) = refl
valid→fromto {sum σ τ} .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) = refl

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive
open import Data.Empty

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

-- This can't be a datatype, since it wouldn't be strictly positive as it
-- appears on the left of an arrow in the function case, which then can be
-- contained in nested "fromto-validity" proofs.
sumfromto : ∀ (σ τ : Type) → (dv : SumChange2 {A = ⟦ σ ⟧Type} {B = ⟦ τ ⟧Type}) → (v1 v2 : ⟦ sum σ τ ⟧Type) → Set
sumfromto σ τ (ch₁ da) (inj₁ a1) (inj₁ a2) = [ σ ] da from a1 to a2
-- These fallback equations unfortunately don't hold definitionally, they're
-- split on multiple cases, so the pattern match is a mess.
--
-- To "case split" on validity, I typically copy-paste the pattern match from
-- fromto→⊕ and change the function name :-(.
sumfromto σ τ (ch₁ da) _ _ = ⊥
sumfromto σ τ (ch₂ db) (inj₂ b1) (inj₂ b2) = [ τ ] db from b1 to b2
sumfromto σ τ (ch₂ db) _ _ = ⊥
sumfromto σ τ (rp (inj₂ b2)) (inj₁ a1) (inj₂ b2') = b2 ≡ b2'
sumfromto σ τ (rp (inj₁ a2)) (inj₂ b1) (inj₁ a2') = a2 ≡ a2'
sumfromto σ τ (rp s) _ _ = ⊥

[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2
[ sum σ τ ] dv from v1 to v2 = sumfromto σ τ (convert dv) v1 v2

data [_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ] dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₁ a2) = ⊝-fromto a1 a2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₂ b2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₁ a2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₂ b2) = ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa rewrite fromto→⊕ da a1 a2 daa = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb rewrite fromto→⊕ db b1 b2 dbb = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst (lit n) = sym (right-id-int n)
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = daa
fromtoDeriveConst rinj db b1 b2 dbb = dbb
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa df f1 f2 dff dg g1 g2 dgg = dff da a1 a2 daa
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb df f1 f2 dff dg g1 g2 dgg = dgg db b1 b2 dbb
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

open import Postulate.Extensionality

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da _ _ daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa = sv₁ a1 da (fromto→valid da a1 a2 daa)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb = sv₂ b1 db (fromto→valid db b1 b2 dbb)
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = svrp₂ b1 a2
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = svrp₁ a1 b2
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)
valid→fromto {sum σ τ} .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) = valid→fromto a da ada
valid→fromto {sum σ τ} .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) = valid→fromto b db bdb
valid→fromto {sum σ τ} .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) = refl
valid→fromto {sum σ τ} .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) = refl