IDescTT model: implement the Vec and Fin examples

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

module IDescTT where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
data Unit  : Set where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {A B C : Set}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

postulate
  reflFun : {A B : Set}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

--********************************************
-- Elimination principle: induction
--********************************************

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

  mutual
    indI : (i : I)(x : IMu R i) -> P (i , x)
    indI i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : Set -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const Set
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma Set (\S -> pi S (\s -> var Void))
descDChoice _ lsigma = sigma Set (\S -> pi S (\s -> var Void))

descD : (I : Set) -> IDesc Unit
descD I = sigma DescDConst (descDChoice I)

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type

--********************************
-- Typed expressions
--********************************

exprFixMenu : (Type -> Set) -> FixMenu Type
exprFixMenu constt = ( consE (consE nilE) ,
                       \ty -> (const (constt ty),
                              (prod (var bool) (prod (var ty) (var ty)),
                               Void)))

choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

expr : (Type -> Set) -> TagIDesc Type
expr constt = exprFixMenu constt , exprSensitiveMenu

exprIDesc : (Type -> Set) -> ((Type -> Set) -> TagIDesc Type) -> (Type -> IDesc Type)
exprIDesc constt D = toIDesc Type  (D constt)

--********************************
-- Closed terms
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc Val expr

--********************************
-- Closed term evaluation
--********************************

eval : (ty : Type) -> IMu closeTerm ty -> Val ty
eval ty term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)

--********************************
-- Open terms
--********************************

Var : EnumU -> Type -> Set
Var dom _ = EnumT dom

openTerm : EnumU -> Type -> IDesc Type
openTerm dom = exprIDesc (\ty -> Val ty + Var dom ty) expr

--********************************
-- Evaluation of open terms
--********************************

discharge : (ty : Type)
          (vars : EnumU)
          (context : spi vars (\_ -> IMu closeTerm ty)) ->
          (Val ty + Var vars ty) ->
          IMu closeTerm ty
discharge ty vars context (l value) = con ( EZe , value )
discharge ty vars context (r variable) = switch vars (\_ -> IMu closeTerm ty) context variable

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

exprFreeFixMenu : FixMenu Type
exprFreeFixMenu = ( consE nilE ,
                    \ty -> (prod (var bool) (prod (var ty) (var ty)),
                           Void))

choiceFreeMenu : Type -> EnumU
choiceFreeMenu nat = consE nilE
choiceFreeMenu bool = consE nilE

choiceFreeDessert : (ty : Type) -> spi (choiceFreeMenu ty) (\ _ -> IDesc Type)
choiceFreeDessert nat = (prod (var nat) (var nat) , Void)
choiceFreeDessert bool = (prod (var nat) (var nat) , Void )

exprFreeSensitiveMenu : SensitiveMenu Type
exprFreeSensitiveMenu = ( choiceFreeMenu ,  choiceFreeDessert )

exprFree : TagIDesc Type
exprFree = exprFreeFixMenu , exprFreeSensitiveMenu

exprFreeC : (Type -> Set) -> TagIDesc Type
exprFreeC X = exprFree ** X

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (exprFree ** Val)

openTerm' : EnumU -> Type -> IDesc Type
openTerm' dom = toIDesc Type (exprFree ** (\ty -> Val ty + Var dom ty))

--********************************
-- Evaluation of open terms'
--********************************

discharge' : (ty : Type)
            (vars : EnumU)
            (context : spi vars (\_ -> IMu closeTerm' ty)) ->
            (Val ty + Var vars ty) ->
            IMu closeTerm' ty
discharge' ty vars context (l value) = con (EZe , value)
discharge' ty vars context (r variable) = switch vars (\_ -> IMu closeTerm' ty) context variable

chooseDom : (ty : Type)(domNat domBool : EnumU) -> EnumU
chooseDom nat domNat _ = domNat
chooseDom bool _ domBool = domBool

chooseGamma : (ty : Type)
              (dom : EnumU)
              (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
              (gammaBool : spi dom (\_ -> IMu closeTerm' bool)) ->
              spi dom (\_ -> IMu closeTerm' ty)
chooseGamma nat dom gammaNat gammaBool = gammaNat
chooseGamma bool dom gammaNat gammaBool = gammaBool

substExpr : (dom : EnumU)
            (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
            (gammaBool : spi dom (\_ -> IMu closeTerm' bool))
            (sigma : (dom : EnumU)
                     (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
                     (gammaBool : spi dom (\_ -> IMu closeTerm' bool))
                     (ty : Type) ->
                     (Val ty + Var dom ty) ->
                     IMu closeTerm' ty)
            (ty : Type) ->
            IMu (openTerm' dom) ty ->
            IMu closeTerm' ty
substExpr dom gammaNat gammaBool sig ty term =
    substI (\ty -> Val ty + Var dom ty)
           Val
           exprFree
           (sig dom gammaNat gammaBool)
           ty
           term

sigmaExpr : (dom : EnumU)
            (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
            (gammaBool : spi dom (\_ -> IMu closeTerm' bool))
            (ty : Type) ->
            (Val ty + Var dom ty) ->
            IMu closeTerm' ty
sigmaExpr dom gammaNat gammaBool ty v =
    discharge' ty
               dom
               (chooseGamma ty dom gammaNat gammaBool)
               v

test : IMu (openTerm' (consE (consE nilE))) nat ->
       IMu closeTerm' nat
test term = substExpr (consE (consE nilE))
                      ( con ( EZe , ze ) , ( con (EZe , su ze ) , Void ))
                      ( con ( EZe , true ) , ( con ( EZe , false ) , Void ))
                      sigmaExpr nat term


Added missing file to a README.agad.

Added missing file to a README.agad.

------------------------------------------------------------------------------
-- Distributive laws on a binary operation (Stanovský example)
------------------------------------------------------------------------------

module DistributiveLaws.README where

-- Let _·_ be a left-associative binary operation which satifies the
-- left and right distributive axioms:
--
-- ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
-- ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z).

-- We prove some properties of Stanovský (2008): Task B, Lemma 3,
-- Lemma 4, Lemma 5 (Task A) and Lemma 6.

------------------------------------------------------------------------------
-- The axioms
open import DistributiveLaws.Base

-- The interactive and combined proofs
open import DistributiveLaws.TaskB-AllStepsATP
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP
open import DistributiveLaws.Lemma3-ATP
open import DistributiveLaws.Lemma4-ATP
open import DistributiveLaws.Lemma5-ATP
open import DistributiveLaws.Lemma6-ATP

-- Unproven theorem by the ATPs
open import DistributiveLaws.TaskB.UnprovedATP

------------------------------------------------------------------------------
-- References:
--
-- Stanovský, David (2008). Distributive Groupoids are
-- Symmetrical-by-Medial: An Elementary Proof. Commentations
-- Mathematicae Universitatis Carolinae 49.4, pp. 541–546.

------------------------------------------------------------------------------
-- Distributive laws on a binary operation (Stanovský example)
------------------------------------------------------------------------------

module DistributiveLaws.README where

-- Let _·_ be a left-associative binary operation which satifies the
-- left and right distributive axioms:
--
-- ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
-- ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z).

-- We prove some properties of Stanovský (2008): Task B, Lemma 3,
-- Lemma 4, Lemma 5 (Task A) and Lemma 6.

------------------------------------------------------------------------------
-- The axioms
open import DistributiveLaws.Base

-- The interactive and combined proofs
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP
open import DistributiveLaws.Lemma3-ATP
open import DistributiveLaws.Lemma4-ATP
open import DistributiveLaws.Lemma5-ATP
open import DistributiveLaws.Lemma6-ATP

-- Unproven theorem by the ATPs
open import DistributiveLaws.TaskB.UnprovedATP

------------------------------------------------------------------------------
-- References:
--
-- Stanovský, David (2008). Distributive Groupoids are
-- Symmetrical-by-Medial: An Elementary Proof. Commentations
-- Mathematicae Universitatis Carolinae 49.4, pp. 541–546.


Describe the purpose of Model.agda (see #28).

There are two comments because I intend to split this file.

Old-commit-hash: f61a7ef89adc97a015021be9ef43504b3b124e96

module Model where

-- SIMPLE TYPES
--
-- This module defines the syntax of simple types.

-- VALUES
--
-- This module defines the model theory of simple types, that is,
-- it defines for every type, the set of values of that type.
--
-- In fact, we only describe a single model here.

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type
  bool : Type

infixr 5 _⇒_

-- Denotational Semantics

data Bool : Set where
  true false : Bool

not : Bool → Bool
not true = false
not false = true

_xor_ : Bool → Bool → Bool
true xor b = not b
false xor b = b

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type
⟦ bool ⟧Type = Bool

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- Value Equivalence
open import Level using (zero)
open import Relation.Binary.PropositionalEquality
postulate ext : Extensionality zero zero

not-not : ∀ a → a ≡ not (not a)
not-not true = refl
not-not false = refl

a-xor-a-false : ∀ a → (a xor a) ≡ false
a-xor-a-false true = refl
a-xor-a-false false = refl

a-xor-false-a : ∀ a → (false xor a) ≡ a
a-xor-false-a b = refl

xor-associative : ∀ a b c → ((b xor c) xor a) ≡ (b xor (c xor a))
xor-associative a true true = not-not a
xor-associative a true false = refl
xor-associative a false c = refl

a-xor-false : ∀ a → a xor false ≡ a
a-xor-false true = refl
a-xor-false false = refl

a-xor-true : ∀ a → a xor true ≡ not a
a-xor-true true = refl
a-xor-true false = refl

xor-commutative : ∀ a b → a xor b ≡ b xor a
xor-commutative true b rewrite a-xor-true b = refl
xor-commutative false b rewrite a-xor-false b = refl

xor-cancellative-2 : ∀ a b → (b xor (a xor a)) ≡ b
xor-cancellative-2 a b rewrite a-xor-a-false a = a-xor-false b

xor-cancellative : ∀ a b → ((b xor a) xor a) ≡ b
xor-cancellative a b rewrite xor-associative a b a = xor-cancellative-2 a b

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl = refl

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym = sym

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans = trans

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong f = cong f
≡-cong₂ : ∀ {τ₃ τ₁ τ₂ v₁ v₂ v₃ v₄} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧ → ⟦ τ₃ ⟧) →
  v₁ ≡ v₂ → v₃ ≡ v₄ → f v₁ v₃ ≡ f v₂ v₄
≡-cong₂ f = cong₂ f

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = ≡-cong₂ (λ x y → x y)

≡-isEquivalence : ∀ {τ : Set} → IsEquivalence (_≡_ {A = τ})
≡-isEquivalence = isEquivalence

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

≡-consistent : ¬ (∀ (τ : Type) → (v₁ v₂ : ⟦ τ ⟧) → v₁ ≡ v₂)
≡-consistent H with H bool true false
... | ()

module Model where

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type
  bool : Type

infixr 5 _⇒_

-- Denotational Semantics

data Bool : Set where
  true false : Bool

not : Bool → Bool
not true = false
not false = true

_xor_ : Bool → Bool → Bool
true xor b = not b
false xor b = b

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type
⟦ bool ⟧Type = Bool

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- Value Equivalence
open import Level using (zero)
open import Relation.Binary.PropositionalEquality
postulate ext : Extensionality zero zero

not-not : ∀ a → a ≡ not (not a)
not-not true = refl
not-not false = refl

a-xor-a-false : ∀ a → (a xor a) ≡ false
a-xor-a-false true = refl
a-xor-a-false false = refl

a-xor-false-a : ∀ a → (false xor a) ≡ a
a-xor-false-a b = refl

xor-associative : ∀ a b c → ((b xor c) xor a) ≡ (b xor (c xor a))
xor-associative a true true = not-not a
xor-associative a true false = refl
xor-associative a false c = refl

a-xor-false : ∀ a → a xor false ≡ a
a-xor-false true = refl
a-xor-false false = refl

a-xor-true : ∀ a → a xor true ≡ not a
a-xor-true true = refl
a-xor-true false = refl

xor-commutative : ∀ a b → a xor b ≡ b xor a
xor-commutative true b rewrite a-xor-true b = refl
xor-commutative false b rewrite a-xor-false b = refl

xor-cancellative-2 : ∀ a b → (b xor (a xor a)) ≡ b
xor-cancellative-2 a b rewrite a-xor-a-false a = a-xor-false b

xor-cancellative : ∀ a b → ((b xor a) xor a) ≡ b
xor-cancellative a b rewrite xor-associative a b a = xor-cancellative-2 a b

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl = refl

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym = sym

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans = trans

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong f = cong f
≡-cong₂ : ∀ {τ₃ τ₁ τ₂ v₁ v₂ v₃ v₄} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧ → ⟦ τ₃ ⟧) →
  v₁ ≡ v₂ → v₃ ≡ v₄ → f v₁ v₃ ≡ f v₂ v₄
≡-cong₂ f = cong₂ f

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = ≡-cong₂ (λ x y → x y)

≡-isEquivalence : ∀ {τ : Set} → IsEquivalence (_≡_ {A = τ})
≡-isEquivalence = isEquivalence

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

≡-consistent : ¬ (∀ (τ : Type) → (v₁ v₂ : ⟦ τ ⟧) → v₁ ≡ v₂)
≡-consistent H with H bool true false
... | ()


In progress adding StableUnderInjection

In progress adding StableUnderInjection

module sum-properties where

open import Type

import Level as L

open import Data.Bool.NP
open import Data.Nat.NP
open import Data.Nat.Properties

open import Function.NP

open import sum

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_ ; _≗_ ; _≗₂_)

sum-lem : ∀ {A : ★}(μA : SumProp A)(f g : A → ℕ) → sum μA f ≡ sum μA (λ x → f x ⊓ g x) + sum μA (λ x → f x ∸ g x)
sum-lem μA f g = ≡.trans (sum-ext μA f≗f⊓g+f∸g) (sum-hom μA (λ x → f x ⊓ g x) (λ x → f x ∸ g x))
  where
    f≗f⊓g+f∸g : f ≗ (λ x → f x ⊓ g x + (f x ∸ g x))
    f≗f⊓g+f∸g x = a≡a⊓b+a∸b (f x) (g x)

sum-lem₂ : ∀ {A : ★}(μA : SumProp A)(f g : A → ℕ) → sum μA f + sum μA g ≡ sum μA (λ x → f x ⊔ g x) + sum μA (λ x → f x ⊓ g x)
sum-lem₂ μA f g =
         sum μA f + sum μA g ≡⟨ ≡.sym (sum-hom μA f g) ⟩
         sum μA (λ x → f x + g x) ≡⟨ sum-ext μA (λ x → lemma (f x) (g x)) ⟩
         sum μA (λ x → f x ⊔ g x + f x ⊓ g x) ≡⟨ sum-hom μA (λ x → f x ⊔ g x) (λ x → f x ⊓ g x) ⟩
         sum μA (λ x → f x ⊔ g x) + sum μA (λ x → f x ⊓ g x) ∎
  where
    open ≡.≡-Reasoning
    lemma : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
    lemma zero b rewrite ℕ°.+-comm b 0 = ≡.refl
    lemma (suc a) zero = ≡.refl
    lemma (suc a) (suc b) rewrite +-assoc-comm a 1 b
                                | +-assoc-comm (a ⊔ b) 1 (a ⊓ b) = ≡.cong (suc ∘ suc) (lemma a b)

toℕ-⊓ : ∀ a b → toℕ a ⊓ toℕ b ≡ toℕ (a ∧ b)
toℕ-⊓ true true = ≡.refl
toℕ-⊓ true false = ≡.refl
toℕ-⊓ false b = ≡.refl

toℕ-⊔ : ∀ a b → toℕ a ⊔ toℕ b ≡ toℕ (a ∨ b)
toℕ-⊔ true true = ≡.refl
toℕ-⊔ true false = ≡.refl
toℕ-⊔ false b = ≡.refl

toℕ-∸ : ∀ a b → toℕ a ∸ toℕ b ≡ toℕ (a ∧ not b)
toℕ-∸ true true = ≡.refl
toℕ-∸ true false = ≡.refl
toℕ-∸ false true = ≡.refl
toℕ-∸ false false = ≡.refl

count-lem : ∀ {A : ★}(μA : SumProp A)(f g : A → Bool)
          → count μA f ≡ count μA (λ x → f x ∧ g x) + count μA (λ x → f x ∧ not (g x))
count-lem μA f g rewrite sum-lem μA (toℕ ∘ f) (toℕ ∘ g)
                       | sum-ext μA (λ x → toℕ-⊓ (f x) (g x))
                       | sum-ext μA (λ x → toℕ-∸ (f x) (g x)) = ≡.refl

count-lem₂ : ∀ {A : ★}(μA : SumProp A)(f g : A → Bool) → count μA f + count μA g ≡ count μA (λ x → f x ∨ g x) + count μA (λ x → f x ∧ g x)
count-lem₂ μA f g rewrite sum-lem₂ μA (toℕ ∘ f) (toℕ ∘ g)
  | sum-ext μA (λ x → toℕ-⊔ (f x) (g x))
  | sum-ext μA (λ x → toℕ-⊓ (f x) (g x)) = ≡.refl

sum-⊔ : ∀ {A : ★}(μA : SumProp A)(f g : A → ℕ) → sum μA (λ x → f x ⊔ g x) ≤ sum μA f + sum μA g
sum-⊔ μA f g = ℕ≤.trans
                 (sum-mono μA (λ x → ⊔≤+ (f x) (g x)))
                 (ℕ≤.reflexive (sum-hom μA f g))
  where
    ⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
    ⊔≤+ zero b = ℕ≤.refl
    ⊔≤+ (suc a) zero = ℕ≤.reflexive (≡.cong suc (ℕ°.+-comm 0 a))
    ⊔≤+ (suc a) (suc b) = s≤s (ℕ≤.trans (⊔≤+ a b) (ℕ≤.trans (≤-step ℕ≤.refl) (ℕ≤.reflexive (+-assoc-comm 1 a b))))

count-∨ : ∀ {A : ★}(μA : SumProp A)(f g : A → Bool) → count μA (λ x → f x ∨ g x) ≤ count μA f + count μA g
count-∨ μA f g = ℕ≤.trans (ℕ≤.reflexive (sum-ext μA (λ x → ≡.sym (toℕ-⊔ (f x) (g x)))))
                          (sum-⊔ μA (toℕ ∘ f) (toℕ ∘ g))

sum-ext₂ : ∀ {A B}{f g : A → B → ℕ}(μA : SumProp A)(μB : SumProp B) → f ≗₂ g → sum μA (sum μB ∘ f) ≡ sum μA (sum μB ∘ g)
sum-ext₂ μA μB f≗g = sum-ext μA (sum-ext μB ∘ f≗g)

Injective : ∀ {a b}{A : Set a}{B : Set b}(f : A → B) → Set (a L.⊔ b)
Injective f = ∀ {x y} → f x ≡ f y → x ≡ y

StableUnderInjection : ∀ {A} → SumProp A → Set
StableUnderInjection μ = ∀ f p → Injective p → sum μ f ≡ sum μ (f ∘ p)

#-StableUnderInjection : ∀ {A}{μ : SumProp A} → StableUnderInjection μ
    → ∀ f p → Injective p → count μ f ≡ count μ (f ∘ p)
#-StableUnderInjection sui f p p-inj = sui (toℕ ∘ f) p p-inj

open import Data.Fin using (Fin ; zero ; suc)

record Finable {A : Set}(μA : SumProp A) : Set where
  constructor mk
  field
    FinCard  : ℕ
    toFin    : A → Fin (suc FinCard)
    fromFin  : Fin (suc FinCard) → A
    to-inj   : Injective toFin
    from-inj : Injective fromFin
    iso      : fromFin ∘ toFin ≗ id
    sums-ok  : ∀ f → sum μA f ≡ sum (μFin FinCard) (f ∘ fromFin)

postulate
  Fin-Stab : ∀ n → StableUnderInjection (μFin n)

⊤-Finable : Finable μ⊤
⊤-Finable = mk 0 (λ x → zero) (λ x → _) (λ x₁ → ≡.refl) (λ x₁ → help) (λ x → ≡.refl) (λ f → ≡.refl)
  where help : {x y : Fin 1} → x ≡ y
        help {zero} {zero} = ≡.refl
        help {zero} {suc ()}
        help {suc ()}

+-Finable : ∀ {A B}(μA : SumProp A)(μB : SumProp B) → Finable μA → Finable μB → Finable (μA +μ μB)
+-Finable {A}{B} μA μB finA finB = mk FinCard toFin fromFin to-inj from-inj iso sums-ok where
    open import Data.Sum
    open import Data.Empty

    |A| = suc (Finable.FinCard finA)
    |B| = suc (Finable.FinCard finB)

    Fsuc-injective : ∀ {n} {i j : Fin n} → Fin.suc i ≡ suc j → i ≡ j
    Fsuc-injective ≡.refl = ≡.refl

    inj₁-inj : ∀ {A B : Set} {x y : A} → inj₁ {B = B} x ≡ inj₁ y → x ≡ y
    inj₁-inj ≡.refl = ≡.refl

    inj₂-inj : ∀ {A B : Set} {x y : B} → inj₂ {A = A} x ≡ inj₂ y → x ≡ y
    inj₂-inj ≡.refl = ≡.refl

    fin₁ : ∀ n {m} → Fin n → Fin (n + m)
    fin₁ zero ()
    fin₁ (suc n) zero = zero
    fin₁ (suc n) (suc i) = suc (fin₁ n i)

    fin₂ : ∀ n {m} → Fin m → Fin (n + m)
    fin₂ zero i = i
    fin₂ (suc n) i = suc (fin₂ n i)

    toFin' : ∀ {n} {m} → Fin n ⊎ Fin m → Fin (n + m)
    toFin' {n} (inj₁ x) = fin₁ n x
    toFin' {n} (inj₂ y) = fin₂ n y

    fin₁-inj : ∀ n {m} → Injective (fin₁ n {m})
    fin₁-inj .(suc n) {m} {zero {n}} {zero} x≡y = ≡.refl
    fin₁-inj .(suc n) {m} {zero {n}} {suc y} ()
    fin₁-inj .(suc n) {m} {suc {n} x} {zero} ()
    fin₁-inj .(suc n) {m} {suc {n} x} {suc y} x≡y = ≡.cong suc (fin₁-inj n (Fsuc-injective x≡y))

    fin₂-inj : ∀ n {m} → Injective (fin₂ n {m})
    fin₂-inj zero eq = eq
    fin₂-inj (suc n) eq = fin₂-inj n (Fsuc-injective eq)

    fin₁≠fin₂ : ∀ n {m} x y → (fin₁ n {m} x ≡ fin₂ n y) → ⊥
    fin₁≠fin₂ .(suc n) (zero {n}) zero ()
    fin₁≠fin₂ .(suc n) (zero {n}) (suc y) ()
    fin₁≠fin₂ .(suc n) (suc {n} x) zero eq = fin₁≠fin₂ n x zero (Fsuc-injective eq)
    fin₁≠fin₂ .(suc n) (suc {n} x) (suc y) eq = fin₁≠fin₂ n x (suc y) (Fsuc-injective eq)

    fromFin' : ∀ n {m} → Fin (n + m) → Fin n ⊎ Fin m
    fromFin' zero k = inj₂ k
    fromFin' (suc n) zero = inj₁ zero
    fromFin' (suc n) (suc k) with fromFin' n k
    ... | inj₁ x = inj₁ (suc x)
    ... | inj₂ y = inj₂ y

    fromFin'-inj : ∀ n {m} x y → fromFin' n {m} x ≡ fromFin' n y → x ≡ y
    fromFin'-inj zero x y eq = inj₂-inj eq
    fromFin'-inj (suc n) zero zero eq = ≡.refl
    fromFin'-inj (suc n) zero (suc y) eq = {!!}
    fromFin'-inj (suc n) (suc x) zero eq = {!!}
    fromFin'-inj (suc n) (suc x) (suc y) eq = {!fromFin'-inj n x y!}

    fromFin'-inj₁ : ∀ n {m} x → fromFin' n {m} (fin₁ n x) ≡ inj₁ x
    fromFin'-inj₁ zero ()
    fromFin'-inj₁ (suc n) zero = ≡.refl
    fromFin'-inj₁ (suc n) {m} (suc x) rewrite fromFin'-inj₁ n {m} x  = ≡.refl

    fromFin'-inj₂ : ∀ n {m} x → fromFin' n {m} (fin₂ n x) ≡ inj₂ x
    fromFin'-inj₂ zero x = ≡.refl
    fromFin'-inj₂ (suc n) x rewrite fromFin'-inj₂ n x = ≡.refl

    FinCard  : ℕ
    FinCard = Finable.FinCard finA + suc (Finable.FinCard finB)

    toFin    : A ⊎ B → Fin (suc FinCard)
    toFin (inj₁ x) = toFin' (inj₁ (Finable.toFin finA x))
    toFin (inj₂ y) = toFin' {n = |A|} (inj₂ (Finable.toFin finB y))

    fromFin  : Fin (suc FinCard) → A ⊎ B
    fromFin x+y with fromFin' |A| x+y
    ... | inj₁ x = inj₁ (Finable.fromFin finA x)
    ... | inj₂ y = inj₂ (Finable.fromFin finB y)

    to-inj   : Injective toFin
    to-inj {inj₁ x} {inj₁ x₁} tx≡ty = ≡.cong inj₁ (Finable.to-inj finA (fin₁-inj |A| tx≡ty))
    to-inj {inj₁ x} {inj₂ y} tx≡ty = ⊥-elim (fin₁≠fin₂ |A| _ _ tx≡ty)
    to-inj {inj₂ y} {inj₁ x} tx≡ty = ⊥-elim (fin₁≠fin₂ |A| _ _ (≡.sym tx≡ty))
    to-inj {inj₂ y} {inj₂ y₁} tx≡ty = ≡.cong inj₂ (Finable.to-inj finB (fin₂-inj |A| tx≡ty))

    from-inj : Injective fromFin
    from-inj {x} {y} fx≡fy = {!!}

    iso      : fromFin ∘ toFin ≗ id
    iso (inj₁ x) rewrite fromFin'-inj₁ |A| {|B|} (Finable.toFin finA x) | Finable.iso finA x = ≡.refl
    iso (inj₂ y) rewrite fromFin'-inj₂ |A| {|B|} (Finable.toFin finB y) | Finable.iso finB y = ≡.refl

    sums-ok  : ∀ f → sum (μA +μ μB) f ≡ sum (μFin FinCard) (f ∘ fromFin)
    sums-ok f =
        sum (μA +μ μB) f
      ≡⟨ ≡.cong₂ _+_ (Finable.sums-ok finA (f ∘ inj₁))
           (Finable.sums-ok finB (f ∘ inj₂)) ⟩
        sum (μFin (Finable.FinCard finA)) (f ∘ inj₁ ∘ Finable.fromFin finA)
      + sum (μFin (Finable.FinCard finB)) (f ∘ inj₂ ∘ Finable.fromFin finB)
      ≡⟨ {!!} ⟩
        sum (μFin FinCard) (f ∘ fromFin)
      ∎
      where open ≡.≡-Reasoning

StableIfFinable : ∀ {A} (μA : SumProp A) → Finable μA → StableUnderInjection μA
StableIfFinable μA fin f p p-inj
  = sum μA f
  ≡⟨ sums-ok f ⟩
    sum (μFin FinCard) (f ∘ fromFin)
  ≡⟨ Fin-Stab FinCard (f ∘ fromFin) (toFin ∘ p ∘ fromFin) (from-inj ∘ p-inj ∘ to-inj) ⟩
    sum (μFin FinCard) (f ∘ fromFin ∘ toFin ∘ p ∘ fromFin)
  ≡⟨ sum-ext (μFin FinCard) (λ x → ≡.cong f (iso (p (fromFin x)))) ⟩
    sum (μFin FinCard) (f ∘ p ∘ fromFin)
  ≡⟨ ≡.sym (sums-ok (f ∘ p)) ⟩
    sum μA (f ∘ p)
  ∎
  where open ≡.≡-Reasoning
        open Finable fin

{-
module _ where
  open import bijection-fin
  open import Data.Vec.NP

  μFinSUI : ∀ {n} → StableUnderInjection (μFin n)
  μFinSUI {n} f p p-inj rewrite ≡.sym (tabulate-∘ f id)
                              | ≡.sym (tabulate-∘ (f ∘ p) id) = count-perm f p (λ x y → p-inj)
-}

module sum-properties where

open import Type

import Level as L

open import Data.Bool.NP
open import Data.Nat.NP
open import Data.Nat.Properties

open import Function.NP

open import sum

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_ ; _≗_ ; _≗₂_)

sum-lem : ∀ {A : ★}(μA : SumProp A)(f g : A → ℕ) → sum μA f ≡ sum μA (λ x → f x ⊓ g x) + sum μA (λ x → f x ∸ g x)
sum-lem μA f g = ≡.trans (sum-ext μA f≗f⊓g+f∸g) (sum-hom μA (λ x → f x ⊓ g x) (λ x → f x ∸ g x))
  where
    f≗f⊓g+f∸g : f ≗ (λ x → f x ⊓ g x + (f x ∸ g x))
    f≗f⊓g+f∸g x = a≡a⊓b+a∸b (f x) (g x)

sum-lem₂ : ∀ {A : ★}(μA : SumProp A)(f g : A → ℕ) → sum μA f + sum μA g ≡ sum μA (λ x → f x ⊔ g x) + sum μA (λ x → f x ⊓ g x)
sum-lem₂ μA f g =
         sum μA f + sum μA g ≡⟨ ≡.sym (sum-hom μA f g) ⟩
         sum μA (λ x → f x + g x) ≡⟨ sum-ext μA (λ x → lemma (f x) (g x)) ⟩
         sum μA (λ x → f x ⊔ g x + f x ⊓ g x) ≡⟨ sum-hom μA (λ x → f x ⊔ g x) (λ x → f x ⊓ g x) ⟩
         sum μA (λ x → f x ⊔ g x) + sum μA (λ x → f x ⊓ g x) ∎
  where
    open ≡.≡-Reasoning
    lemma : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
    lemma zero b rewrite ℕ°.+-comm b 0 = ≡.refl
    lemma (suc a) zero = ≡.refl
    lemma (suc a) (suc b) rewrite +-assoc-comm a 1 b
                                | +-assoc-comm (a ⊔ b) 1 (a ⊓ b) = ≡.cong (suc ∘ suc) (lemma a b)

toℕ-⊓ : ∀ a b → toℕ a ⊓ toℕ b ≡ toℕ (a ∧ b)
toℕ-⊓ true true = ≡.refl
toℕ-⊓ true false = ≡.refl
toℕ-⊓ false b = ≡.refl

toℕ-⊔ : ∀ a b → toℕ a ⊔ toℕ b ≡ toℕ (a ∨ b)
toℕ-⊔ true true = ≡.refl
toℕ-⊔ true false = ≡.refl
toℕ-⊔ false b = ≡.refl

toℕ-∸ : ∀ a b → toℕ a ∸ toℕ b ≡ toℕ (a ∧ not b)
toℕ-∸ true true = ≡.refl
toℕ-∸ true false = ≡.refl
toℕ-∸ false true = ≡.refl
toℕ-∸ false false = ≡.refl

count-lem : ∀ {A : ★}(μA : SumProp A)(f g : A → Bool)
          → count μA f ≡ count μA (λ x → f x ∧ g x) + count μA (λ x → f x ∧ not (g x))
count-lem μA f g rewrite sum-lem μA (toℕ ∘ f) (toℕ ∘ g)
                       | sum-ext μA (λ x → toℕ-⊓ (f x) (g x))
                       | sum-ext μA (λ x → toℕ-∸ (f x) (g x)) = ≡.refl

count-lem₂ : ∀ {A : ★}(μA : SumProp A)(f g : A → Bool) → count μA f + count μA g ≡ count μA (λ x → f x ∨ g x) + count μA (λ x → f x ∧ g x)
count-lem₂ μA f g rewrite sum-lem₂ μA (toℕ ∘ f) (toℕ ∘ g)
  | sum-ext μA (λ x → toℕ-⊔ (f x) (g x))
  | sum-ext μA (λ x → toℕ-⊓ (f x) (g x)) = ≡.refl

sum-⊔ : ∀ {A : ★}(μA : SumProp A)(f g : A → ℕ) → sum μA (λ x → f x ⊔ g x) ≤ sum μA f + sum μA g
sum-⊔ μA f g = ℕ≤.trans
                 (sum-mono μA (λ x → ⊔≤+ (f x) (g x)))
                 (ℕ≤.reflexive (sum-hom μA f g))
  where
    ⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
    ⊔≤+ zero b = ℕ≤.refl
    ⊔≤+ (suc a) zero = ℕ≤.reflexive (≡.cong suc (ℕ°.+-comm 0 a))
    ⊔≤+ (suc a) (suc b) = s≤s (ℕ≤.trans (⊔≤+ a b) (ℕ≤.trans (≤-step ℕ≤.refl) (ℕ≤.reflexive (+-assoc-comm 1 a b))))

count-∨ : ∀ {A : ★}(μA : SumProp A)(f g : A → Bool) → count μA (λ x → f x ∨ g x) ≤ count μA f + count μA g
count-∨ μA f g = ℕ≤.trans (ℕ≤.reflexive (sum-ext μA (λ x → ≡.sym (toℕ-⊔ (f x) (g x)))))
                          (sum-⊔ μA (toℕ ∘ f) (toℕ ∘ g))

sum-ext₂ : ∀ {A B}{f g : A → B → ℕ}(μA : SumProp A)(μB : SumProp B) → f ≗₂ g → sum μA (sum μB ∘ f) ≡ sum μA (sum μB ∘ g)
sum-ext₂ μA μB f≗g = sum-ext μA (sum-ext μB ∘ f≗g)

Injective : ∀ {a b}{A : Set a}{B : Set b}(f : A → B) → Set (a L.⊔ b)
Injective f = ∀ {x y} → f x ≡ f y → x ≡ y

StableUnderInjection : ∀ {A} → SumProp A → Set
StableUnderInjection μ = ∀ f p → Injective p → sum μ f ≡ sum μ (f ∘ p)

module _ where
  open import bijection-fin
  open import Data.Vec.NP

  μFinSUI : ∀ {n} → StableUnderInjection (μFin n)
  μFinSUI {n} f p p-inj rewrite ≡.sym (tabulate-∘ f id)
                              | ≡.sym (tabulate-∘ (f ∘ p) id) = count-perm f p (λ x y → p-inj)

#-StableUnderInjection : ∀ {A}{μ : SumProp A} → StableUnderInjection μ
    → ∀ f p → Injective p → count μ f ≡ count μ (f ∘ p)
#-StableUnderInjection sui f p p-inj = sui (toℕ ∘ f) p p-inj


possible agda bug demonstration

possible agda bug demonstration

module IndexLF where

open import Common
open import LinLogic
--open import LinDepT
--open import LinT
--open import SetLL
--open import SetLLProp
--open import SetLLRem
open import LinFun

open import Data.Product

data IndexLFC {i u} : ∀{ll rll} → LFun {i} {u} ll rll → Set where
  ↓c    : ∀{ll ∞rll prf ∞lf} → IndexLFC (call {i} {u} {ll} {∞rll} {prf} ∞lf)
  _←⊂ : ∀{rll pll ell ll ind elf lf}
         → IndexLFC elf
         → IndexLFC (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  ⊂→_ : ∀{rll pll ell ll ind elf lf}
         → IndexLFC lf
         → IndexLFC (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  tr   : ∀{ll orll rll} → {ltr : LLTr orll ll} → {lf : LFun {i} {u} orll rll}
         → IndexLFC lf → IndexLFC (tr ltr lf)
  com  : ∀{rll ll frll prfi prfo df lf}
         → IndexLFC lf
         → IndexLFC (com {i} {u} {rll} {ll} {frll} {{prfi}} {{prfo}} df lf)

data SetLFC {i u oll orll} (olf : LFun {i} {u} oll orll) : ∀{ll rll} → LFun {i} {u} ll rll → Set (lsuc u) where
  ↓c    : ∀{ll ∞rll prf ∞lf} → IndexLFC olf → SetLFC olf (call {i} {u} {ll} {∞rll} {prf} ∞lf)
  _←⊂ : ∀{rll pll ell ll ind elf lf}
         → SetLFC olf elf
         → SetLFC olf (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  ⊂→_ : ∀{rll pll ell ll ind elf lf}
         → SetLFC olf lf
         → SetLFC olf (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  _←⊂→_ : ∀{rll pll ell ll ind elf lf}
         → SetLFC olf elf
         → SetLFC olf lf
         → SetLFC olf (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  tr   : ∀{ll orll rll} → {ltr : LLTr orll ll} → {lf : LFun {i} {u} orll rll}
         → SetLFC olf lf
         → SetLFC olf (tr ltr lf)
  com  : ∀{rll ll frll prfi prfo df lf}
         → SetLFC olf lf
         → SetLFC olf (com {i} {u} {rll} {ll} {frll} {{prfi}} {{prfo}} df lf)

data MSetLFC {i u oll orll} (olf : LFun {i} {u} oll orll) : ∀{ll rll} → LFun {i} {u} ll rll → Set (lsuc u) where
  ∅   : ∀{ll rll} → {lf : LFun {i} {u} ll rll}            → MSetLFC olf lf
  ¬∅  : ∀{ll rll} → {lf : LFun {i} {u} ll rll} → SetLFC olf lf → MSetLFC olf lf

∅-addLFC : ∀{i u oll orll ll rll} → {olf : LFun {i} {u} oll orll} → {lf : LFun {i} {u} ll rll} → IndexLFC olf → IndexLFC lf → SetLFC olf lf
∅-addLFC oic ↓c = ↓c oic
∅-addLFC oic (ic ←⊂) = (∅-addLFC oic ic) ←⊂
∅-addLFC oic (⊂→ ic) = ⊂→ (∅-addLFC oic ic)
∅-addLFC oic (tr ic) = tr (∅-addLFC oic ic)
∅-addLFC oic (com ic) = com (∅-addLFC oic ic)

addLFC : ∀{i u oll orll ll rll} → {olf : LFun {i} {u} oll orll} → {lf : LFun {i} {u} ll rll} → SetLFC olf lf → IndexLFC olf → IndexLFC lf → SetLFC olf lf
addLFC (↓c x) oic ↓c = ↓c oic -- replace
addLFC (s ←⊂) oic (ic ←⊂) = (addLFC s oic ic) ←⊂
addLFC (⊂→ s) oic (ic ←⊂) = (∅-addLFC oic ic) ←⊂→ s
addLFC (s ←⊂→ s₁) oic (ic ←⊂) =  (addLFC s oic ic) ←⊂→ s₁
addLFC (s ←⊂) oic (⊂→ ic) = s ←⊂→ (∅-addLFC oic ic)
addLFC (⊂→ s) oic (⊂→ ic) = ⊂→ (addLFC s oic ic)
addLFC (s ←⊂→ s₁) oic (⊂→ ic) = s ←⊂→ (addLFC s₁ oic ic)
addLFC (tr s) oic (tr ic) = tr (addLFC s oic ic)
addLFC (com s) oic (com ic) = com (addLFC s oic ic)

maddLFC : ∀{i u oll orll ll rll} → {olf : LFun {i} {u} oll orll} → {lf : LFun {i} {u} ll rll} → MSetLFC olf lf → IndexLFC olf → IndexLFC lf → MSetLFC olf lf
maddLFC ∅ oic ic = ¬∅ (∅-addLFC oic ic)
maddLFC (¬∅ x) oic ic = ¬∅ (addLFC x oic ic)

data SetLFCRem {i u oll orll} (olf : LFun {i} {u} oll orll) : LinLogic i {u} → Set (lsuc u) where
  ↓c    : ∀{∞ll} → IndexLFC {i} olf                     → SetLFCRem olf (call ∞ll)
  _←∧   : ∀{rs ls} → SetLFCRem olf ls                   → SetLFCRem olf (ls ∧ rs)
  ∧→_   : ∀{rs ls} → SetLFCRem olf rs                   → SetLFCRem olf (ls ∧ rs)
  _←∧→_ : ∀{rs ls} → SetLFCRem olf ls → SetLFCRem olf rs → SetLFCRem olf (ls ∧ rs)
  _←∨   : ∀{rs ls} → SetLFCRem olf ls                   → SetLFCRem olf (ls ∨ rs)
  ∨→_   : ∀{rs ls} → SetLFCRem olf rs                   → SetLFCRem olf (ls ∨ rs)
  _←∨→_ : ∀{rs ls} → SetLFCRem olf ls → SetLFCRem olf rs → SetLFCRem olf (ls ∨ rs)
  _←∂   : ∀{rs ls} → SetLFCRem olf ls                   → SetLFCRem olf (ls ∂ rs)
  ∂→_   : ∀{rs ls} → SetLFCRem olf rs                   → SetLFCRem olf (ls ∂ rs)
  _←∂→_ : ∀{rs ls} → SetLFCRem olf ls → SetLFCRem olf rs → SetLFCRem olf (ls ∂ rs)

data MSetLFCRem {i u oll orll} (olf : LFun {i} {u} oll orll) : LinLogic i {u} → Set (lsuc u) where
  ∅   : ∀{ll}            → MSetLFCRem olf ll
  ¬∅  : ∀{ll} → SetLFCRem olf ll → MSetLFCRem olf ll

∅-addLFCRem : ∀{i u ll ∞rll oll orll} → {olf : LFun {i} {u} oll orll} → (ind : IndexLL {i} {u} (call ∞rll) ll) → IndexLFC olf
        → SetLFCRem olf ll
∅-addLFCRem ↓ m = ↓c m
∅-addLFCRem (ind ←∧) m = (∅-addLFCRem ind m) ←∧
∅-addLFCRem (∧→ ind) m = ∧→ (∅-addLFCRem ind m)
∅-addLFCRem (ind ←∨) m = (∅-addLFCRem ind m) ←∨
∅-addLFCRem (∨→ ind) m = ∨→ (∅-addLFCRem ind m)
∅-addLFCRem (ind ←∂) m = (∅-addLFCRem ind m) ←∂
∅-addLFCRem (∂→ ind) m = ∂→ (∅-addLFCRem ind m)

addLFCRem : ∀{i u ll ∞rll oll orll} → {olf : LFun {i} {u} oll orll} → SetLFCRem olf ll → (ind : IndexLL {i} {u} (call ∞rll) ll) → IndexLFC olf
        → SetLFCRem olf ll
addLFCRem (↓c rm) ind m               = ↓c m
addLFCRem (s ←∧) (ind ←∧) m     = (addLFCRem s ind m) ←∧
addLFCRem (s ←∧) (∧→ ind) m     = s ←∧→ (∅-addLFCRem ind m)
addLFCRem (∧→ s) (ind ←∧) m     = (∅-addLFCRem ind m) ←∧→ s
addLFCRem (∧→ s) (∧→ ind) m     = ∧→ addLFCRem s ind m
addLFCRem (s ←∧→ s₁) (ind ←∧) m = (addLFCRem s ind m) ←∧→ s₁
addLFCRem (s ←∧→ s₁) (∧→ ind) m = s ←∧→ (addLFCRem s₁ ind m)
addLFCRem (s ←∨) (ind ←∨) m     = (addLFCRem s ind m) ←∨
addLFCRem (s ←∨) (∨→ ind) m     = s ←∨→ (∅-addLFCRem ind m)
addLFCRem (∨→ s) (ind ←∨) m     = (∅-addLFCRem ind m) ←∨→ s
addLFCRem (∨→ s) (∨→ ind) m     = ∨→ addLFCRem s ind m
addLFCRem (s ←∨→ s₁) (ind ←∨) m = (addLFCRem s ind m) ←∨→ s₁
addLFCRem (s ←∨→ s₁) (∨→ ind) m = s ←∨→ (addLFCRem s₁ ind m)
addLFCRem (s ←∂) (ind ←∂) m     = (addLFCRem s ind m) ←∂
addLFCRem (s ←∂) (∂→ ind) m     = s ←∂→ (∅-addLFCRem ind m)
addLFCRem (∂→ s) (ind ←∂) m     = (∅-addLFCRem ind m) ←∂→ s
addLFCRem (∂→ s) (∂→ ind) m     = ∂→ addLFCRem s ind m
addLFCRem (s ←∂→ s₁) (ind ←∂) m = (addLFCRem s ind m) ←∂→ s₁
addLFCRem (s ←∂→ s₁) (∂→ ind) m = s ←∂→ (addLFCRem s₁ ind m)

madd : ∀{i u ll ∞rll oll orll} → {olf : LFun {i} {u} oll orll} → MSetLFCRem olf ll → (ind : IndexLL {i} {u} (call ∞rll) ll) → IndexLFC olf
      → MSetLFCRem olf ll
madd ∅ ind m = ¬∅ (∅-addLFCRem ind m)
madd (¬∅ x) ind m = ¬∅ (addLFCRem x ind m)

truncSetLFCRem : ∀{i} → ∀{u ll oll orll q} → {olf : LFun {i} {u} oll orll} → MSetLFCRem {i} {u} olf ll → (ind : IndexLL {i} {u} q ll) → MSetLFCRem {i} olf q
truncSetLFCRem ∅ ind = ∅
truncSetLFCRem (¬∅ x) ↓ = ¬∅ x
truncSetLFCRem (¬∅ (x ←∧)) (ind ←∧) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (∧→ x)) (ind ←∧) = ∅
truncSetLFCRem (¬∅ (x ←∧→ x₁)) (ind ←∧) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∧)) (∧→ ind) = ∅
truncSetLFCRem (¬∅ (∧→ x)) (∧→ ind) =  truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∧→ x₁)) (∧→ ind) =  truncSetLFCRem (¬∅ x₁) ind
truncSetLFCRem (¬∅ (x ←∨)) (ind ←∨) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (∨→ x)) (ind ←∨) = ∅
truncSetLFCRem (¬∅ (x ←∨→ x₁)) (ind ←∨) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∨)) (∨→ ind) = ∅
truncSetLFCRem (¬∅ (∨→ x)) (∨→ ind) =  truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∨→ x₁)) (∨→ ind) =  truncSetLFCRem (¬∅ x₁) ind
truncSetLFCRem (¬∅ (x ←∂)) (ind ←∂) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (∂→ x)) (ind ←∂) = ∅
truncSetLFCRem (¬∅ (x ←∂→ x₁)) (ind ←∂) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∂)) (∂→ ind) = ∅
truncSetLFCRem (¬∅ (∂→ x)) (∂→ ind) =  truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∂→ x₁)) (∂→ ind) =  truncSetLFCRem (¬∅ x₁) ind

delLFCRem : ∀{i u oll orll ll pll} → {olf : LFun {i} {u} oll orll} → SetLFCRem {i} olf ll → (ind : IndexLL {i} {u} pll ll) → (rll : LinLogic i)
      → MSetLFCRem {i} olf (replLL ll ind rll)
delLFCRem s ↓ rll = ∅
delLFCRem (s ←∧) (ind ←∧) rll with (delLFCRem s ind rll)
delLFCRem (s ←∧) (ind ←∧) rll | ∅ = ∅
delLFCRem (s ←∧) (ind ←∧) rll | ¬∅ x = ¬∅ (x ←∧)
delLFCRem (∧→ s) (ind ←∧) rll = ¬∅ (∧→ (s))
delLFCRem (s ←∧→ s₁) (ind ←∧) rll with (delLFCRem s ind rll)
delLFCRem (s ←∧→ s₁) (ind ←∧) rll | ∅ = ¬∅ (∧→ (s₁))
delLFCRem (s ←∧→ s₁) (ind ←∧) rll | ¬∅ x = ¬∅ (x ←∧→ (s₁))
delLFCRem (s ←∧) (∧→ ind) rll = ¬∅ ((s) ←∧)
delLFCRem (∧→ s) (∧→ ind) rll with (delLFCRem s ind rll)
delLFCRem (∧→ s) (∧→ ind) rll | ∅ = ∅
delLFCRem (∧→ s) (∧→ ind) rll | ¬∅ x = ¬∅ (∧→ x)
delLFCRem (s ←∧→ s₁) (∧→ ind) rll with (delLFCRem s₁ ind rll)
delLFCRem (s ←∧→ s₁) (∧→ ind) rll | ∅ = ¬∅ ((s) ←∧)
delLFCRem (s ←∧→ s₁) (∧→ ind) rll | ¬∅ x = ¬∅ ((s) ←∧→ x)
delLFCRem (s ←∨) (ind ←∨) rll with (delLFCRem s ind rll)
delLFCRem (s ←∨) (ind ←∨) rll | ∅ = ∅
delLFCRem (s ←∨) (ind ←∨) rll | ¬∅ x = ¬∅ (x ←∨)
delLFCRem (∨→ s) (ind ←∨) rll = ¬∅ (∨→ (s))
delLFCRem (s ←∨→ s₁) (ind ←∨) rll with (delLFCRem s ind rll)
delLFCRem (s ←∨→ s₁) (ind ←∨) rll | ∅ = ¬∅ (∨→ (s₁))
delLFCRem (s ←∨→ s₁) (ind ←∨) rll | ¬∅ x = ¬∅ (x ←∨→ (s₁))
delLFCRem (s ←∨) (∨→ ind) rll = ¬∅ ((s) ←∨)
delLFCRem (∨→ s) (∨→ ind) rll with (delLFCRem s ind rll)
delLFCRem (∨→ s) (∨→ ind) rll | ∅ = ∅
delLFCRem (∨→ s) (∨→ ind) rll | ¬∅ x = ¬∅ (∨→ x)
delLFCRem (s ←∨→ s₁) (∨→ ind) rll with (delLFCRem s₁ ind rll)
delLFCRem (s ←∨→ s₁) (∨→ ind) rll | ∅ = ¬∅ ((s) ←∨)
delLFCRem (s ←∨→ s₁) (∨→ ind) rll | ¬∅ x = ¬∅ ((s) ←∨→ x)
delLFCRem (s ←∂) (ind ←∂) rll with (delLFCRem s ind rll)
delLFCRem (s ←∂) (ind ←∂) rll | ∅ = ∅
delLFCRem (s ←∂) (ind ←∂) rll | ¬∅ x = ¬∅ (x ←∂)
delLFCRem (∂→ s) (ind ←∂) rll = ¬∅ (∂→ (s))
delLFCRem (s ←∂→ s₁) (ind ←∂) rll with (delLFCRem s ind rll)
delLFCRem (s ←∂→ s₁) (ind ←∂) rll | ∅ = ¬∅ (∂→ (s₁))
delLFCRem (s ←∂→ s₁) (ind ←∂) rll | ¬∅ x = ¬∅ (x ←∂→ (s₁))
delLFCRem (s ←∂) (∂→ ind) rll = ¬∅ ((s) ←∂)
delLFCRem (∂→ s) (∂→ ind) rll with (delLFCRem s ind rll)
delLFCRem (∂→ s) (∂→ ind) rll | ∅ = ∅
delLFCRem (∂→ s) (∂→ ind) rll | ¬∅ x = ¬∅ (∂→ x)
delLFCRem (s ←∂→ s₁) (∂→ ind) rll with (delLFCRem s₁ ind rll)
delLFCRem (s ←∂→ s₁) (∂→ ind) rll | ∅ = ¬∅ ((s) ←∂)
delLFCRem (s ←∂→ s₁) (∂→ ind) rll | ¬∅ x = ¬∅ ((s) ←∂→ x)

mdelLFCRem : ∀{i u oll orll ll pll} → {olf : LFun {i} {u} oll orll} → MSetLFCRem {i} olf ll → (ind : IndexLL {i} {u} pll ll) → (rll : LinLogic i)
             → MSetLFCRem {i} olf (replLL ll ind rll)
mdelLFCRem ∅ ind rll = ∅
mdelLFCRem (¬∅ x) ind rll = delLFCRem x ind rll

tranLFCRem : ∀{i u oll orll ll rll} → {olf : LFun {i} {u} oll orll} → SetLFCRem {i} olf ll → (tr : LLTr {i} {u} rll ll)
       → SetLFCRem olf rll
tranLFCRem s I                           = s
tranLFCRem (s ←∂) (∂c ltr)                = tranLFCRem (∂→ s) ltr
tranLFCRem (∂→ s) (∂c ltr)                = tranLFCRem (s ←∂) ltr
tranLFCRem (s ←∂→ s₁) (∂c ltr)            = tranLFCRem (s₁ ←∂→ s) ltr
tranLFCRem (s ←∨) (∨c ltr)                = tranLFCRem (∨→ s) ltr
tranLFCRem (∨→ s) (∨c ltr)                = tranLFCRem (s ←∨) ltr
tranLFCRem (s ←∨→ s₁) (∨c ltr)            = tranLFCRem (s₁ ←∨→ s) ltr
tranLFCRem (s ←∧) (∧c ltr)                = tranLFCRem (∧→ s) ltr
tranLFCRem (∧→ s) (∧c ltr)                = tranLFCRem (s ←∧) ltr
tranLFCRem (s ←∧→ s₁) (∧c ltr)            = tranLFCRem (s₁ ←∧→ s) ltr
tranLFCRem ((s ←∧) ←∧) (∧∧d ltr)          = tranLFCRem (s ←∧) ltr
tranLFCRem ((∧→ s) ←∧) (∧∧d ltr)          = tranLFCRem (∧→ (s ←∧)) ltr
tranLFCRem ((s ←∧→ s₁) ←∧) (∧∧d ltr)      = tranLFCRem (s ←∧→ (s₁ ←∧)) ltr
tranLFCRem (∧→ s) (∧∧d ltr)               = tranLFCRem (∧→ (∧→ s)) ltr
tranLFCRem ((s ←∧) ←∧→ s₁) (∧∧d ltr)      = tranLFCRem (s ←∧→ (∧→ s₁)) ltr
tranLFCRem ((∧→ s) ←∧→ s₁) (∧∧d ltr)      = tranLFCRem (∧→ (s ←∧→ s₁)) ltr
tranLFCRem ((s ←∧→ s₁) ←∧→ s₂) (∧∧d ltr)  = tranLFCRem (s ←∧→ (s₁ ←∧→ s₂)) ltr
tranLFCRem (s ←∧) (¬∧∧d ltr)              = tranLFCRem ((s ←∧) ←∧) ltr
tranLFCRem (∧→ (s ←∧)) (¬∧∧d ltr)         = tranLFCRem ((∧→ s) ←∧) ltr
tranLFCRem (∧→ (∧→ s)) (¬∧∧d ltr)         = tranLFCRem (∧→ s) ltr
tranLFCRem (∧→ (s ←∧→ s₁)) (¬∧∧d ltr)     = tranLFCRem ((∧→ s) ←∧→ s₁) ltr
tranLFCRem (s ←∧→ (s₁ ←∧)) (¬∧∧d ltr)     = tranLFCRem ((s ←∧→ s₁) ←∧) ltr
tranLFCRem (s ←∧→ (∧→ s₁)) (¬∧∧d ltr)     = tranLFCRem ((s ←∧) ←∧→ s₁) ltr
tranLFCRem (s ←∧→ (s₁ ←∧→ s₂)) (¬∧∧d ltr) = tranLFCRem ((s ←∧→ s₁) ←∧→ s₂) ltr
tranLFCRem ((s ←∨) ←∨) (∨∨d ltr)          = tranLFCRem (s ←∨) ltr
tranLFCRem ((∨→ s) ←∨) (∨∨d ltr)          = tranLFCRem (∨→ (s ←∨)) ltr
tranLFCRem ((s ←∨→ s₁) ←∨) (∨∨d ltr)      = tranLFCRem (s ←∨→ (s₁ ←∨)) ltr
tranLFCRem (∨→ s) (∨∨d ltr)               = tranLFCRem (∨→ (∨→ s)) ltr
tranLFCRem ((s ←∨) ←∨→ s₁) (∨∨d ltr)      = tranLFCRem (s ←∨→ (∨→ s₁)) ltr
tranLFCRem ((∨→ s) ←∨→ s₁) (∨∨d ltr)      = tranLFCRem (∨→ (s ←∨→ s₁)) ltr
tranLFCRem ((s ←∨→ s₁) ←∨→ s₂) (∨∨d ltr)  = tranLFCRem (s ←∨→ (s₁ ←∨→ s₂)) ltr
tranLFCRem (s ←∨) (¬∨∨d ltr)              = tranLFCRem ((s ←∨) ←∨) ltr
tranLFCRem (∨→ (s ←∨)) (¬∨∨d ltr)         = tranLFCRem ((∨→ s) ←∨) ltr
tranLFCRem (∨→ (∨→ s)) (¬∨∨d ltr)         = tranLFCRem (∨→ s) ltr
tranLFCRem (∨→ (s ←∨→ s₁)) (¬∨∨d ltr)     = tranLFCRem ((∨→ s) ←∨→ s₁) ltr
tranLFCRem (s ←∨→ (s₁ ←∨)) (¬∨∨d ltr)     = tranLFCRem ((s ←∨→ s₁) ←∨) ltr
tranLFCRem (s ←∨→ (∨→ s₁)) (¬∨∨d ltr)     = tranLFCRem ((s ←∨) ←∨→ s₁) ltr
tranLFCRem (s ←∨→ (s₁ ←∨→ s₂)) (¬∨∨d ltr) = tranLFCRem ((s ←∨→ s₁) ←∨→ s₂) ltr
tranLFCRem ((s ←∂) ←∂) (∂∂d ltr)          = tranLFCRem (s ←∂) ltr
tranLFCRem ((∂→ s) ←∂) (∂∂d ltr)          = tranLFCRem (∂→ (s ←∂)) ltr
tranLFCRem ((s ←∂→ s₁) ←∂) (∂∂d ltr)      = tranLFCRem (s ←∂→ (s₁ ←∂)) ltr
tranLFCRem (∂→ s) (∂∂d ltr)               = tranLFCRem (∂→ (∂→ s)) ltr
tranLFCRem ((s ←∂) ←∂→ s₁) (∂∂d ltr)      = tranLFCRem (s ←∂→ (∂→ s₁)) ltr
tranLFCRem ((∂→ s) ←∂→ s₁) (∂∂d ltr)      = tranLFCRem (∂→ (s ←∂→ s₁)) ltr
tranLFCRem ((s ←∂→ s₁) ←∂→ s₂) (∂∂d ltr)  = tranLFCRem (s ←∂→ (s₁ ←∂→ s₂)) ltr
tranLFCRem (s ←∂) (¬∂∂d ltr)              = tranLFCRem ((s ←∂) ←∂) ltr
tranLFCRem (∂→ (s ←∂)) (¬∂∂d ltr)         = tranLFCRem ((∂→ s) ←∂) ltr
tranLFCRem (∂→ (∂→ s)) (¬∂∂d ltr)         = tranLFCRem (∂→ s) ltr
tranLFCRem (∂→ (s ←∂→ s₁)) (¬∂∂d ltr)     = tranLFCRem ((∂→ s) ←∂→ s₁) ltr
tranLFCRem (s ←∂→ (s₁ ←∂)) (¬∂∂d ltr)     = tranLFCRem ((s ←∂→ s₁) ←∂) ltr
tranLFCRem (s ←∂→ (∂→ s₁)) (¬∂∂d ltr)     = tranLFCRem ((s ←∂) ←∂→ s₁) ltr
tranLFCRem (s ←∂→ (s₁ ←∂→ s₂)) (¬∂∂d ltr) = tranLFCRem ((s ←∂→ s₁) ←∂→ s₂) ltr

extendLFCRem : ∀{i u oll orll ll pll} → {olf : LFun {i} {u} oll orll} → IndexLL {i} {u} pll ll → SetLFCRem {i} olf pll → SetLFCRem olf ll
extendLFCRem ↓ sr = sr
extendLFCRem (ind ←∧) sr = (extendLFCRem ind sr) ←∧
extendLFCRem (∧→ ind) sr = ∧→ (extendLFCRem ind sr)
extendLFCRem (ind ←∨) sr = (extendLFCRem ind sr) ←∨
extendLFCRem (∨→ ind) sr = ∨→ (extendLFCRem ind sr)
extendLFCRem (ind ←∂) sr = (extendLFCRem ind sr) ←∂
extendLFCRem (∂→ ind) sr = ∂→ (extendLFCRem ind sr)

replaceLFCRem : ∀{i u oll orll ll pll rll} → {olf : LFun {i} {u} oll orll} → (ind : IndexLL {i} {u} pll ll) → SetLFCRem {i} olf rll → SetLFCRem olf ll → SetLFCRem olf (replLL ll ind rll)
replaceLFCRem ↓ esr sr = esr
replaceLFCRem {rll = rll} (ind ←∧) esr (sr ←∧) = replaceLFCRem ind esr sr ←∧
replaceLFCRem {rll = rll} (ind ←∧) esr (∧→ sr) = (extendLFCRem (updateIndex rll ind) esr) ←∧→ sr
replaceLFCRem {rll = rll} (ind ←∧) esr (sr ←∧→ sr₁) = (replaceLFCRem ind esr sr) ←∧→ sr₁
replaceLFCRem {rll = rll} (∧→ ind) esr (sr ←∧) = sr ←∧→ (extendLFCRem (updateIndex rll ind) esr)
replaceLFCRem {rll = rll} (∧→ ind) esr (∧→ sr) = ∧→ replaceLFCRem ind esr sr
replaceLFCRem {rll = rll} (∧→ ind) esr (sr ←∧→ sr₁) = sr ←∧→ replaceLFCRem ind esr sr₁
replaceLFCRem {rll = rll} (ind ←∨) esr (sr ←∨) = replaceLFCRem ind esr sr ←∨
replaceLFCRem {rll = rll} (ind ←∨) esr (∨→ sr) = (extendLFCRem (updateIndex rll ind) esr) ←∨→ sr
replaceLFCRem {rll = rll} (ind ←∨) esr (sr ←∨→ sr₁) = (replaceLFCRem ind esr sr) ←∨→ sr₁
replaceLFCRem {rll = rll} (∨→ ind) esr (sr ←∨) = sr ←∨→ (extendLFCRem (updateIndex rll ind) esr)
replaceLFCRem {rll = rll} (∨→ ind) esr (∨→ sr) = ∨→ replaceLFCRem ind esr sr
replaceLFCRem {rll = rll} (∨→ ind) esr (sr ←∨→ sr₁) = sr ←∨→ replaceLFCRem ind esr sr₁
replaceLFCRem {rll = rll} (ind ←∂) esr (sr ←∂) = replaceLFCRem ind esr sr ←∂
replaceLFCRem {rll = rll} (ind ←∂) esr (∂→ sr) = (extendLFCRem (updateIndex rll ind) esr) ←∂→ sr
replaceLFCRem {rll = rll} (ind ←∂) esr (sr ←∂→ sr₁) = (replaceLFCRem ind esr sr) ←∂→ sr₁
replaceLFCRem {rll = rll} (∂→ ind) esr (sr ←∂) = sr ←∂→ (extendLFCRem (updateIndex rll ind) esr)
replaceLFCRem {rll = rll} (∂→ ind) esr (∂→ sr) = ∂→ replaceLFCRem ind esr sr
replaceLFCRem {rll = rll} (∂→ ind) esr (sr ←∂→ sr₁) = sr ←∂→ replaceLFCRem ind esr sr₁

mreplaceLFCRem :  ∀{i u oll orll ll pll rll} → {olf : LFun {i} {u} oll orll} → (ind : IndexLL {i} {u} pll ll) → MSetLFCRem {i} olf rll → MSetLFCRem olf ll → MSetLFCRem olf (replLL ll ind rll)
mreplaceLFCRem ind ∅ ∅ = ∅
mreplaceLFCRem {rll = rll} ind ∅ (¬∅ x) = delLFCRem x ind rll
mreplaceLFCRem {rll = rll} ind (¬∅ x) ∅ = ¬∅ (extendLFCRem (updateIndex rll ind) x)
mreplaceLFCRem ind (¬∅ x) (¬∅ x₁) = ¬∅ (replaceLFCRem ind x x₁)

findCallGraph : ∀{i u oll orll ll rll} → {olf : LFun {i} {u} oll orll} → (lf : LFun {i} {u} ll rll) → (IndexLFC lf → IndexLFC olf) → MSetLFCRem olf ll → MSetLFC olf olf → MSetLFCRem olf rll × MSetLFC olf olf
findCallGraph I if msr ms = msr , ms
findCallGraph (_⊂_ {ind = ind} lf lf₁) if msr ms = let emsr , ems = findCallGraph lf (λ x → if (x ←⊂)) (truncSetLFCRem msr ind) ms
                                                in findCallGraph lf₁ (λ x → if (⊂→ x)) (mreplaceLFCRem ind emsr msr) ems
findCallGraph (tr ltr lf) if ∅ ms = ∅ , ms
findCallGraph (tr ltr lf) if (¬∅ x) ms = findCallGraph lf (λ x → if (tr x)) (¬∅ $ tranLFCRem x ltr) ms
findCallGraph (com df lf) if ∅ ms = findCallGraph lf (λ x → if (com x)) ∅ ms
findCallGraph (com df lf) if (¬∅ x) ms = IMPOSSIBLE
findCallGraph {ll = ll} {rll = rll} {olf = olf} (call x) if msr ms = {!!} -- where

--findCallGraph {ll = ll} {rll = call .∞rll} {olf = olf} (call {∞rll = ∞rll} x) if msr ms = {!!} -- where

--  hf : IndexLFC olf → MSetLFCRem olf ll → MSetLFC olf olf → MSetLFCRem olf rll × MSetLFC olf olf
--  hf oic msr ms = {!!}

module IndexLF where

open import Common
open import LinLogic
--open import LinDepT
--open import LinT
--open import SetLL
--open import SetLLProp
--open import SetLLRem
open import LinFun

open import Data.Product

data IndexLFC {i u} : ∀{ll rll} → LFun {i} {u} ll rll → Set where
  ↓    : ∀{ll rll} → {lf : LFun {i} {u} ll rll} → IndexLFC lf
  _←⊂_ : ∀{rll pll ell ll ind elf lf}
         → IndexLFC elf
         → IndexLFC (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  _⊂→_ : ∀{rll pll ell ll ind elf lf}
         → IndexLFC lf
         → IndexLFC (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  tr   : ∀{ll orll rll} → {ltr : LLTr orll ll} → {lf : LFun {i} {u} orll rll}
         → IndexLFC lf → IndexLFC (tr ltr lf)
  com  : ∀{rll ll frll prfi prfo df lf}
         → IndexLFC lf
         → IndexLFC (com {i} {u} {rll} {ll} {frll} {{prfi}} {{prfo}} df lf)

data SetLFC {i u oll orll} (olf : LFun {i} {u} oll orll) : ∀{ll rll} → LFun {i} {u} ll rll → Set (lsuc u) where
  ↓    : ∀{ll rll} → {lf : LFun {i} {u} ll rll} → IndexLFC olf → SetLFC olf lf
  _←⊂_ : ∀{rll pll ell ll ind elf lf}
         → SetLFC olf elf
         → SetLFC olf (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  _⊂→_ : ∀{rll pll ell ll ind elf lf}
         → SetLFC olf lf
         → SetLFC olf (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  _←⊂→_ : ∀{rll pll ell ll ind elf lf}
         → SetLFC olf elf
         → SetLFC olf lf
         → SetLFC olf (_⊂_ {i} {u} {pll} {ll} {ell} {rll} {ind} elf lf)
  tr   : ∀{ll orll rll} → {ltr : LLTr orll ll} → {lf : LFun {i} {u} orll rll}
         → SetLFC olf lf
         → SetLFC olf (tr ltr lf)
  com  : ∀{rll ll frll prfi prfo df lf}
         → SetLFC olf lf
         → SetLFC olf (com {i} {u} {rll} {ll} {frll} {{prfi}} {{prfo}} df lf)

data MSetLFC {i u oll orll} (olf : LFun {i} {u} oll orll) : ∀{ll rll} → LFun {i} {u} ll rll → Set (lsuc u) where
  ∅   : ∀{ll rll} → {lf : LFun {i} {u} ll rll}            → MSetLFC olf lf
  ¬∅  : ∀{ll rll} → {lf : LFun {i} {u} ll rll} → SetLFC olf lf → MSetLFC olf lf

data SetLFCRem {i u oll orll} (olf : LFun {i} {u} oll orll) : LinLogic i {u} → Set (lsuc u) where
  ↓c    : ∀{∞ll} → IndexLFC {i} olf                     → SetLFCRem olf (call ∞ll)
  _←∧   : ∀{rs ls} → SetLFCRem olf ls                   → SetLFCRem olf (ls ∧ rs)
  ∧→_   : ∀{rs ls} → SetLFCRem olf rs                   → SetLFCRem olf (ls ∧ rs)
  _←∧→_ : ∀{rs ls} → SetLFCRem olf ls → SetLFCRem olf rs → SetLFCRem olf (ls ∧ rs)
  _←∨   : ∀{rs ls} → SetLFCRem olf ls                   → SetLFCRem olf (ls ∨ rs)
  ∨→_   : ∀{rs ls} → SetLFCRem olf rs                   → SetLFCRem olf (ls ∨ rs)
  _←∨→_ : ∀{rs ls} → SetLFCRem olf ls → SetLFCRem olf rs → SetLFCRem olf (ls ∨ rs)
  _←∂   : ∀{rs ls} → SetLFCRem olf ls                   → SetLFCRem olf (ls ∂ rs)
  ∂→_   : ∀{rs ls} → SetLFCRem olf rs                   → SetLFCRem olf (ls ∂ rs)
  _←∂→_ : ∀{rs ls} → SetLFCRem olf ls → SetLFCRem olf rs → SetLFCRem olf (ls ∂ rs)

data MSetLFCRem {i u oll orll} (olf : LFun {i} {u} oll orll) : LinLogic i {u} → Set (lsuc u) where
  ∅   : ∀{ll}            → MSetLFCRem olf ll
  ¬∅  : ∀{ll} → SetLFCRem olf ll → MSetLFCRem olf ll

truncSetLFCRem : ∀{i} → ∀{u ll oll orll q} → {olf : LFun {i} {u} oll orll} → MSetLFCRem {i} {u} olf ll → (ind : IndexLL {i} {u} q ll) → MSetLFCRem {i} olf q
truncSetLFCRem ∅ ind = ∅
truncSetLFCRem (¬∅ x) ↓ = ¬∅ x
truncSetLFCRem (¬∅ (x ←∧)) (ind ←∧) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (∧→ x)) (ind ←∧) = ∅
truncSetLFCRem (¬∅ (x ←∧→ x₁)) (ind ←∧) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∧)) (∧→ ind) = ∅
truncSetLFCRem (¬∅ (∧→ x)) (∧→ ind) =  truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∧→ x₁)) (∧→ ind) =  truncSetLFCRem (¬∅ x₁) ind
truncSetLFCRem (¬∅ (x ←∨)) (ind ←∨) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (∨→ x)) (ind ←∨) = ∅
truncSetLFCRem (¬∅ (x ←∨→ x₁)) (ind ←∨) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∨)) (∨→ ind) = ∅
truncSetLFCRem (¬∅ (∨→ x)) (∨→ ind) =  truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∨→ x₁)) (∨→ ind) =  truncSetLFCRem (¬∅ x₁) ind
truncSetLFCRem (¬∅ (x ←∂)) (ind ←∂) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (∂→ x)) (ind ←∂) = ∅
truncSetLFCRem (¬∅ (x ←∂→ x₁)) (ind ←∂) = truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∂)) (∂→ ind) = ∅
truncSetLFCRem (¬∅ (∂→ x)) (∂→ ind) =  truncSetLFCRem (¬∅ x) ind
truncSetLFCRem (¬∅ (x ←∂→ x₁)) (∂→ ind) =  truncSetLFCRem (¬∅ x₁) ind

delLFCRem : ∀{i u oll orll ll pll} → {olf : LFun {i} {u} oll orll} → SetLFCRem {i} olf ll → (ind : IndexLL {i} {u} pll ll) → (rll : LinLogic i)
      → MSetLFCRem {i} olf (replLL ll ind rll)
delLFCRem s ↓ rll = ∅
delLFCRem (s ←∧) (ind ←∧) rll with (delLFCRem s ind rll)
delLFCRem (s ←∧) (ind ←∧) rll | ∅ = ∅
delLFCRem (s ←∧) (ind ←∧) rll | ¬∅ x = ¬∅ (x ←∧)
delLFCRem (∧→ s) (ind ←∧) rll = ¬∅ (∧→ (s))
delLFCRem (s ←∧→ s₁) (ind ←∧) rll with (delLFCRem s ind rll)
delLFCRem (s ←∧→ s₁) (ind ←∧) rll | ∅ = ¬∅ (∧→ (s₁))
delLFCRem (s ←∧→ s₁) (ind ←∧) rll | ¬∅ x = ¬∅ (x ←∧→ (s₁))
delLFCRem (s ←∧) (∧→ ind) rll = ¬∅ ((s) ←∧)
delLFCRem (∧→ s) (∧→ ind) rll with (delLFCRem s ind rll)
delLFCRem (∧→ s) (∧→ ind) rll | ∅ = ∅
delLFCRem (∧→ s) (∧→ ind) rll | ¬∅ x = ¬∅ (∧→ x)
delLFCRem (s ←∧→ s₁) (∧→ ind) rll with (delLFCRem s₁ ind rll)
delLFCRem (s ←∧→ s₁) (∧→ ind) rll | ∅ = ¬∅ ((s) ←∧)
delLFCRem (s ←∧→ s₁) (∧→ ind) rll | ¬∅ x = ¬∅ ((s) ←∧→ x)
delLFCRem (s ←∨) (ind ←∨) rll with (delLFCRem s ind rll)
delLFCRem (s ←∨) (ind ←∨) rll | ∅ = ∅
delLFCRem (s ←∨) (ind ←∨) rll | ¬∅ x = ¬∅ (x ←∨)
delLFCRem (∨→ s) (ind ←∨) rll = ¬∅ (∨→ (s))
delLFCRem (s ←∨→ s₁) (ind ←∨) rll with (delLFCRem s ind rll)
delLFCRem (s ←∨→ s₁) (ind ←∨) rll | ∅ = ¬∅ (∨→ (s₁))
delLFCRem (s ←∨→ s₁) (ind ←∨) rll | ¬∅ x = ¬∅ (x ←∨→ (s₁))
delLFCRem (s ←∨) (∨→ ind) rll = ¬∅ ((s) ←∨)
delLFCRem (∨→ s) (∨→ ind) rll with (delLFCRem s ind rll)
delLFCRem (∨→ s) (∨→ ind) rll | ∅ = ∅
delLFCRem (∨→ s) (∨→ ind) rll | ¬∅ x = ¬∅ (∨→ x)
delLFCRem (s ←∨→ s₁) (∨→ ind) rll with (delLFCRem s₁ ind rll)
delLFCRem (s ←∨→ s₁) (∨→ ind) rll | ∅ = ¬∅ ((s) ←∨)
delLFCRem (s ←∨→ s₁) (∨→ ind) rll | ¬∅ x = ¬∅ ((s) ←∨→ x)
delLFCRem (s ←∂) (ind ←∂) rll with (delLFCRem s ind rll)
delLFCRem (s ←∂) (ind ←∂) rll | ∅ = ∅
delLFCRem (s ←∂) (ind ←∂) rll | ¬∅ x = ¬∅ (x ←∂)
delLFCRem (∂→ s) (ind ←∂) rll = ¬∅ (∂→ (s))
delLFCRem (s ←∂→ s₁) (ind ←∂) rll with (delLFCRem s ind rll)
delLFCRem (s ←∂→ s₁) (ind ←∂) rll | ∅ = ¬∅ (∂→ (s₁))
delLFCRem (s ←∂→ s₁) (ind ←∂) rll | ¬∅ x = ¬∅ (x ←∂→ (s₁))
delLFCRem (s ←∂) (∂→ ind) rll = ¬∅ ((s) ←∂)
delLFCRem (∂→ s) (∂→ ind) rll with (delLFCRem s ind rll)
delLFCRem (∂→ s) (∂→ ind) rll | ∅ = ∅
delLFCRem (∂→ s) (∂→ ind) rll | ¬∅ x = ¬∅ (∂→ x)
delLFCRem (s ←∂→ s₁) (∂→ ind) rll with (delLFCRem s₁ ind rll)
delLFCRem (s ←∂→ s₁) (∂→ ind) rll | ∅ = ¬∅ ((s) ←∂)
delLFCRem (s ←∂→ s₁) (∂→ ind) rll | ¬∅ x = ¬∅ ((s) ←∂→ x)

mdelLFCRem : ∀{i u oll orll ll pll} → {olf : LFun {i} {u} oll orll} → MSetLFCRem {i} olf ll → (ind : IndexLL {i} {u} pll ll) → (rll : LinLogic i)
             → MSetLFCRem {i} olf (replLL ll ind rll)
mdelLFCRem ∅ ind rll = ∅
mdelLFCRem (¬∅ x) ind rll = delLFCRem x ind rll

mreplaceLFCRem :  ∀{i u oll orll ll pll rll} → {olf : LFun {i} {u} oll orll} → (ind : IndexLL {i} {u} pll ll) → MSetLFCRem {i} olf rll → MSetLFCRem olf ll → MSetLFCRem olf (replLL ll ind rll)
mreplaceLFCRem ind ∅ ∅ = ∅
mreplaceLFCRem ind ∅ (¬∅ x) = {!!}
mreplaceLFCRem ind (¬∅ x) ms = {!!}

findCallGraph : ∀{i u oll orll ll rll} → {olf : LFun {i} {u} oll orll} → (lf : LFun {i} {u} ll rll) → MSetLFCRem olf ll → MSetLFC olf olf → MSetLFCRem olf rll × MSetLFC olf olf
findCallGraph I msr ms = msr , ms
findCallGraph (_⊂_ {ind = ind} lf lf₁) msr ms = let emsr , ems = findCallGraph lf (truncSetLFCRem msr ind) ms
                                                in {!!}
findCallGraph (tr ltr lf) msr ms = {!!}
findCallGraph (com df lf) msr ms = {!!}
findCallGraph (call x) msr ms = {!!}


Clarify the problem even more

Clarify the problem even more

--
-- In this module we conclude our proof: we have shown that t, derive-dterm t
-- and produce related values (in the sense of the fundamental property,
-- rfundamental3), and for related values v1, dv and v2 we have v1 ⊕ dv ≡
-- v2 (because ⊕ agrees with validity, rrelV3→⊕).
--
-- We now put these facts together via derive-correct-si and derive-correct.
-- This is immediate, even though I spend so much code on it:
-- Indeed, all theorems are immediate corollaries of what we established (as
-- explained above); only the statements are longer, especially because I bother
-- expanding them.

module Thesis.SIRelBigStep.DeriveCorrect where

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

open import Thesis.SIRelBigStep.IlcSILR
open import Thesis.SIRelBigStep.FundamentalProperty

-- Theorem statement. This theorem still mentions step-indexes explicitly.
derive-correct-si-type =
  ∀ {τ Γ k} (t : Term Γ τ) ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3-skeleton (λ v1 dv v2 _ → v1 ⊕ dv ≡ v2) t (derive-dterm t) t ρ1 dρ ρ2 k

-- A verified expansion of the theorem statement.
derive-correct-si-type-means :
  derive-correct-si-type ≡
  ∀ {τ Γ k} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  (v1 v2 : Val τ) →
  ∀ j (j<k : j < k) →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct-si-type-means = refl

derive-correct-si : derive-correct-si-type
derive-correct-si t ρ1 dρ ρ2 ρρ = rrelT3→⊕ t (derive-dterm t) t ρ1 dρ ρ2 (rfundamental3 _ t ρ1 dρ ρ2 ρρ)

-- Infinitely related environments:
rrelρ3-inf : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3-inf Γ ρ1 dρ ρ2 = ∀ k → rrelρ3 Γ ρ1 dρ ρ2 k

-- A theorem statement for infinitely-related environments. On paper, if we informally
-- omit the arbitrary derivation step-index as usual, we get a statement without
-- step-indexes.
derive-correct :
  ∀ {τ Γ} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3-inf Γ ρ1 dρ ρ2) →
  (v1 v2 : Val τ) →
  ∀ j →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct t ρ1 dρ ρ2 ρρ v1 v2 j = derive-correct-si t ρ1 dρ ρ2 (ρρ (suc j)) v1 v2 j ≤-refl

open import Data.Unit

nilρ : ∀ {Γ n} (ρ : ⟦ Γ ⟧Context) → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ dρ ρ n
nilV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n
nilV (closure t ρ) = let dρ , ρρ = nilρ ρ in dclosure (derive-dterm t) ρ dρ , rfundamental3svv _ (abs t) ρ dρ ρ ρρ
nilV (natV n₁) = dnatV zero , refl
nilV (pairV a b) = let 0a , aa = nilV a; 0b , bb = nilV b in dpairV 0a 0b , aa , bb

nilρ ∅ = ∅ , tt
nilρ (v • ρ) = let dv , vv = nilV v ; dρ , ρρ = nilρ ρ in dv • dρ , vv , ρρ

-- -- Try to prove to define validity-preserving change composition.
-- -- If we don't store proofs that environment changes in closures are valid, we
-- -- can't finish the proof for the closure case using the Fundamental property.
-- -- But it seems that's not the approach we need to use: we might need
-- -- environment validity elsewhere.
-- -- Moreover, the proof is annoying to do unless we build a datatype to invert
-- -- validity proofs (as suggested by Ezyang in
-- -- http://blog.ezyang.com/2013/09/induction-and-logical-relations/).

-- ocomposeρ : ∀ {Γ} n ρ1 dρ1 ρ2 dρ2 ρ3 → rrelρ3 Γ ρ1 dρ1 ρ2 n → rrelρ3 Γ ρ2 dρ2 ρ3 n → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ1 dρ ρ3 n

-- ocomposev : ∀ {τ} n v1 dv1 v2 dv2 v3 → rrelV3 τ v1 dv1 v2 n → rrelV3 τ v2 dv2 v3 n → Σ[ dv ∈ DVal τ ] rrelV3 τ v1 dv v3 n
-- ocomposev n v1 dv1 v2 (bang v3) .v3 vv1 refl = bang v3 , refl
-- ocomposev n v1 (bang x) v2 (dclosure dt ρ dρ) v3 vv1 vv2 = {!!}
-- ocomposev n (closure t ρ) (dclosure .(derive-dterm t) .ρ dρ1) (closure .t .(ρ ⊕ρ dρ1)) (dclosure .(derive-dterm t) .(ρ ⊕ρ dρ1) dρ2) (closure .t .((ρ ⊕ρ dρ1) ⊕ρ dρ2)) ((refl , refl) , refl , refl , refl , refl , vv1) ((refl , refl) , refl , refl , refl , refl , vv2) =
--   let dρ , ρρ = ocomposeρ n ρ dρ1 (ρ ⊕ρ dρ1) dρ2 ((ρ ⊕ρ dρ1) ⊕ρ dρ2) {!!} {!!}
--   in dclosure (derive-dterm t) ρ dρ , (refl , refl) , refl , {!!} , refl , refl ,
--     λ { k (s≤s k≤n) v1 dv v2 vv →
--       let nilv2 , nilv2v = nilV v2
--       -- vv1 k ? v1 dv v2 vv
--       -- vv2 k ? v2 nilv2 v2 nilv2v
--       in {!!}
--       }
--       -- rfundamental3 k t (v1 • ρ) (dv • dρ) (v2 • ((ρ ⊕ρ dρ1) ⊕ρ dρ2)) (vv , rrelρ3-mono k n (≤-step k<n) _ ρ dρ ((ρ ⊕ρ dρ1) ⊕ρ dρ2) ρρ)}
-- -- p1 , p2 , p3 , p4 , p5
-- ocomposev n v1 dv1 v2 (dnatV n₁) v3 vv1 vv2 = {!!}
-- ocomposev n v1 dv1 v2 (dpairV dv2 dv3) v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (bang v2) .v2 dv2 v3 refl vv2 = bang (v2 ⊕ dv2) , rrelV3→⊕ v2 dv2 v3 vv2
-- -- ocomposev n v1 (dclosure dt ρ dρ) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dnatV n₁) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dpairV dv1 dv2) v2 dv3 v3 vv1 vv2 = {!!}
-- -- ocomposeV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n

-- ocomposeρ {∅} n ∅ dρ1 ρ2 dρ2 ∅ ρρ1 ρρ2 = ∅ , tt
-- ocomposeρ {τ • Γ} n (v1 • ρ1) (dv1 • dρ1) (v2 • ρ2) (dv2 • dρ2) (v3 • ρ3) (vv1 , ρρ1) (vv2 , ρρ2) =
--   let dv , vv = ocomposev n v1 dv1 v2 dv2 v3 vv1 vv2
--       dρ , ρρ = ocomposeρ n ρ1 dρ1 ρ2 dρ2 ρ3 ρρ1 ρρ2
--   in  dv • dρ , vv , ρρ

-- -- But we sort of know how to store environments validity proofs in closures, you just need to use well-founded inductions, even if you're using types. Sad, yes, that's insanely tedious. Let's leave that to Coq.
-- -- What is also interesting: if that were fixed, could we prove correct
-- -- composition for change *terms* and rrelT3? And for *open expressions*? The
-- -- last is the main problem Ahmed run into.

-- 1: the proof of transitivity of rrelT by Ahmed is for the case where the second rrelT holds at arbitrary step counts :-)
-- 2: that proof doesn't go through for us. If de1 : e1 -> e2 and de2 : e2 ->
-- e3, we must show that if e1 and e3 evaluate something happens, but to use our
-- hypothesis we need that e2 also terminates, which in our case does not
-- follow. For Ahmed 2006, instead, e1 terminates and e1 ≤ e2 implies that e2
-- terminates.
--
-- Indeed, it seems that we can have a change from e1 to looping e2 and a change
-- from looping e2 to e3, and I don't expect the composition of such changes to
-- satisfy anything.
--
-- Indeed, "Imperative self-adjusting computation" does not mention any
-- transitivity result (even in the technical report).

--
-- In this module we conclude our proof: we have shown that t, derive-dterm t
-- and produce related values (in the sense of the fundamental property,
-- rfundamental3), and for related values v1, dv and v2 we have v1 ⊕ dv ≡
-- v2 (because ⊕ agrees with validity, rrelV3→⊕).
--
-- We now put these facts together via derive-correct-si and derive-correct.
-- This is immediate, even though I spend so much code on it:
-- Indeed, all theorems are immediate corollaries of what we established (as
-- explained above); only the statements are longer, especially because I bother
-- expanding them.

module Thesis.SIRelBigStep.DeriveCorrect where

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

open import Thesis.SIRelBigStep.IlcSILR
open import Thesis.SIRelBigStep.FundamentalProperty

-- Theorem statement. This theorem still mentions step-indexes explicitly.
derive-correct-si-type =
  ∀ {τ Γ k} (t : Term Γ τ) ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3-skeleton (λ v1 dv v2 _ → v1 ⊕ dv ≡ v2) t (derive-dterm t) t ρ1 dρ ρ2 k

-- A verified expansion of the theorem statement.
derive-correct-si-type-means :
  derive-correct-si-type ≡
  ∀ {τ Γ k} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  (v1 v2 : Val τ) →
  ∀ j (j<k : j < k) →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct-si-type-means = refl

derive-correct-si : derive-correct-si-type
derive-correct-si t ρ1 dρ ρ2 ρρ = rrelT3→⊕ t (derive-dterm t) t ρ1 dρ ρ2 (rfundamental3 _ t ρ1 dρ ρ2 ρρ)

-- Infinitely related environments:
rrelρ3-inf : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3-inf Γ ρ1 dρ ρ2 = ∀ k → rrelρ3 Γ ρ1 dρ ρ2 k

-- A theorem statement for infinitely-related environments. On paper, if we informally
-- omit the arbitrary derivation step-index as usual, we get a statement without
-- step-indexes.
derive-correct :
  ∀ {τ Γ} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3-inf Γ ρ1 dρ ρ2) →
  (v1 v2 : Val τ) →
  ∀ j →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct t ρ1 dρ ρ2 ρρ v1 v2 j = derive-correct-si t ρ1 dρ ρ2 (ρρ (suc j)) v1 v2 j ≤-refl

open import Data.Unit

nilρ : ∀ {Γ n} (ρ : ⟦ Γ ⟧Context) → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ dρ ρ n
nilV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n
nilV (closure t ρ) = let dρ , ρρ = nilρ ρ in dclosure (derive-dterm t) ρ dρ , rfundamental3svv _ (abs t) ρ dρ ρ ρρ
nilV (natV n₁) = dnatV zero , refl
nilV (pairV a b) = let 0a , aa = nilV a; 0b , bb = nilV b in dpairV 0a 0b , aa , bb

nilρ ∅ = ∅ , tt
nilρ (v • ρ) = let dv , vv = nilV v ; dρ , ρρ = nilρ ρ in dv • dρ , vv , ρρ

-- Try to prove to define validity-preserving change composition.
-- Sadly, if we don't store proofs that environment changes in closures are valid, we can't finish the proof for the closure case :-(.
-- Moreover, the proof is annoying to do unless we build a datatype to invert
-- validity proofs (as suggested by Ezyang in
-- http://blog.ezyang.com/2013/09/induction-and-logical-relations/).

-- ocomposeρ : ∀ {Γ} n ρ1 dρ1 ρ2 dρ2 ρ3 → rrelρ3 Γ ρ1 dρ1 ρ2 n → rrelρ3 Γ ρ2 dρ2 ρ3 n → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ1 dρ ρ3 n

-- ocomposev : ∀ {τ} n v1 dv1 v2 dv2 v3 → rrelV3 τ v1 dv1 v2 n → rrelV3 τ v2 dv2 v3 n → Σ[ dv ∈ DVal τ ] rrelV3 τ v1 dv v3 n
-- ocomposev n v1 dv1 v2 (bang v3) .v3 vv1 refl = bang v3 , refl
-- ocomposev n v1 (bang x) v2 (dclosure dt ρ dρ) v3 vv1 vv2 = {!!}
-- ocomposev n (closure t ρ) (dclosure .(derive-dterm t) .ρ dρ1) (closure .t .(ρ ⊕ρ dρ1)) (dclosure .(derive-dterm t) .(ρ ⊕ρ dρ1) dρ2) (closure .t .((ρ ⊕ρ dρ1) ⊕ρ dρ2)) ((refl , refl) , refl , refl , refl , refl , p5) ((refl , refl) , refl , refl , refl , refl , p5q) =
--   let dρ , ρρ = ocomposeρ n ρ dρ1 (ρ ⊕ρ dρ1) dρ2 ((ρ ⊕ρ dρ1) ⊕ρ dρ2) {!!} {!!}
--   in dclosure (derive-dterm t) ρ dρ , (refl , refl) , refl , {!!} , refl , refl ,
--     λ { k (s≤s k<n) v1 dv v2 vv →
--       rfundamental3 k t (v1 • ρ) (dv • dρ) (v2 • ((ρ ⊕ρ dρ1) ⊕ρ dρ2)) (vv , rrelρ3-mono k n (≤-step k<n) _ ρ dρ ((ρ ⊕ρ dρ1) ⊕ρ dρ2) ρρ)}
-- -- p1 , p2 , p3 , p4 , p5
-- ocomposev n v1 dv1 v2 (dnatV n₁) v3 vv1 vv2 = {!!}
-- ocomposev n v1 dv1 v2 (dpairV dv2 dv3) v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (bang v2) .v2 dv2 v3 refl vv2 = bang (v2 ⊕ dv2) , rrelV3→⊕ v2 dv2 v3 vv2
-- -- ocomposev n v1 (dclosure dt ρ dρ) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dnatV n₁) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dpairV dv1 dv2) v2 dv3 v3 vv1 vv2 = {!!}
-- -- ocomposeV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n

-- ocomposeρ {∅} n ∅ dρ1 ρ2 dρ2 ∅ ρρ1 ρρ2 = ∅ , tt
-- ocomposeρ {τ • Γ} n (v1 • ρ1) (dv1 • dρ1) (v2 • ρ2) (dv2 • dρ2) (v3 • ρ3) (vv1 , ρρ1) (vv2 , ρρ2) =
--   let dv , vv = ocomposev n v1 dv1 v2 dv2 v3 vv1 vv2
--       dρ , ρρ = ocomposeρ n ρ1 dρ1 ρ2 dρ2 ρ3 ρρ1 ρρ2
--   in  dv • dρ , vv , ρρ

-- But we sort of know how to store environments validity proofs in closures, you just need to use well-founded inductions, even if you're using types. Sad, yes, that's insanely tedious. Let's leave that to Coq.
-- What is also interesting: if that were fixed, could we prove correct
-- composition for change *terms* and rrelT3? And for *open expressions*? The
-- last is the main problem Ahmed run into.