Proved that curry and uncurry from a bijection.

-----------------------------------------------------------------------
-- This file defines DC₂(Sets) and its SMC structure.              --
-----------------------------------------------------------------------
module DC2Sets where

open import prelude

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (U → X → Set))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , α) (V , Y , β) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , α)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , α)}{(V , Y , β)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , α}{V , Y , β}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , α}{V , Y , β}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , α}{V , Y , β}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , α}
         {V , Y , β}
         {W , Z , γ}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , α}{V , Y , β}{W , Z , γ}{S , T , ι}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _}{V , Y , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _}{V , Y , _}{f , F , _} = refl , refl

-----------------------------------------------------------------------
-- DC₂(Sets) is a SMC                                              --
-----------------------------------------------------------------------

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , α) ⊗ₒ (V , Y , β) = ((U × V) , (X × Y) , α ⊗ᵣ β)

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

-- The unit for tensor:
ι : ⊤ → ⊤ → Set
ι triv triv = ⊤

I : Obj
I = (⊤ , ⊤ , ι)

J : Obj
J = (⊤ , ⊤ , (λ x y → ⊥))

-- The left-unitor:
λ⊗-p : ∀{U X α}{u : Σ ⊤ (λ x → U)} {y : X} → (ι ⊗ᵣ α) u (triv , y) → α (snd u) y
λ⊗-p {U}{X}{α}{(triv , u)}{x} = snd

λ⊗ : ∀{A : Obj} → Hom (I ⊗ₒ A) A
λ⊗ {(U , X , α)} = snd , (λ _ x → triv , x) , λ⊗-p

λ⊗-inv : ∀{A : Obj} → Hom A (I ⊗ₒ A)
λ⊗-inv {(U , X , α)} = (λ u → triv , u) , (λ _ r → snd r) , λ⊗-inv-p
 where
  λ⊗-inv-p : ∀{U X α}{u : U} {y : Σ ⊤ (λ x → X)} → α u (snd y) → (ι ⊗ᵣ α) (triv , u) y
  λ⊗-inv-p {U}{X}{α}{u}{triv , x} p = triv , p

-- The right-unitor:
ρ⊗ : ∀{A : Obj} → Hom (A ⊗ₒ I) A
ρ⊗ {(U , X , α)} = fst , (λ r x → x , triv) , ρ⊗-p
 where
  ρ⊗-p : ∀{U X α}{u : Σ U (λ x → ⊤)} {y : X} → (α ⊗ᵣ ι) u (y , triv) → α (fst u) y
  ρ⊗-p {U}{X}{α}{(u , _)}{x} (p , _) = p

ρ⊗-inv : ∀{A : Obj} → Hom A (A ⊗ₒ I)
ρ⊗-inv {(U , X , α)} = (λ u → u , triv) , (λ u r → fst r) , ρ⊗-p-inv
 where
  ρ⊗-p-inv : ∀{U X α}{u : U} {y : Σ X (λ x → ⊤)} → α u (fst y) → (α ⊗ᵣ ι) (u , triv) y
  ρ⊗-p-inv {U}{X}{α}{u}{x , triv} p = p , triv

-- Symmetry:
β⊗ : ∀{A B : Obj} → Hom (A ⊗ₒ B) (B ⊗ₒ A)
β⊗ {(U , X , α)}{(V , Y , β)} = twist-× , (λ r₁ r₂ → twist-× r₂) , β⊗-p
 where
   β⊗-p : ∀{U V Y X α β}{u : Σ U (λ x → V)} {y : Σ Y (λ x → X)} → (α ⊗ᵣ β) u (twist-× y) → (β ⊗ᵣ α) (twist-× u) y
   β⊗-p {U}{V}{Y}{X}{α}{β}{u , v}{y , x} = twist-×

-- The associator:
Fα-inv : ∀{ℓ}{U V W X Y Z : Set ℓ} → (U × (V × W)) → ((X × Y) × Z) → (X × (Y × Z))
Fα-inv (u , (v , w)) ((x , y) , z) = x , y , z

α⊗-inv : ∀{A B C : Obj} → Hom (A ⊗ₒ (B ⊗ₒ C)) ((A ⊗ₒ B) ⊗ₒ C)
α⊗-inv {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = rl-assoc-× , Fα-inv , α-inv-cond
 where
   α-inv-cond : {u : Σ U (λ x → Σ V (λ x₁ → W))}{y : Σ (Σ X (λ x → Y)) (λ x → Z)}
     → (α ⊗ᵣ (β ⊗ᵣ γ)) u (Fα-inv u y)
     → ((α ⊗ᵣ β) ⊗ᵣ γ) (rl-assoc-× u) y
   α-inv-cond {u , (v , w)}{(x , y) , z} (p₁ , (p₂ , p₃)) = (p₁ , p₂) , p₃

Fα : ∀{V W X Y U Z : Set} → ((U × V) × W) → (X × (Y × Z)) → ((X × Y) × Z)
Fα {V}{W}{X}{Y}{U}{Z} ((u , v) , w) (x , (y , z)) = (x , y) , z

α⊗ : ∀{A B C : Obj} → Hom ((A ⊗ₒ B) ⊗ₒ C) (A ⊗ₒ (B ⊗ₒ C))
α⊗ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = (lr-assoc-× , Fα , α-cond)
 where
  α-cond : {u : Σ (Σ U (λ x → V)) (λ x → W)}
      {y : Σ X (λ x → Σ Y (λ x₁ → Z))} →
      ((α ⊗ᵣ β) ⊗ᵣ γ) u (Fα u y) → (α ⊗ᵣ (β ⊗ᵣ γ)) (lr-assoc-× u) y
  α-cond {(u , v) , w}{x , (y , z)} ((p₁ , p₂) , p₃) = p₁ , p₂ , p₃

α⊗-id₁ : ∀{A B C} → (α⊗ {A}{B}{C}) ○ α⊗-inv ≡h id
α⊗-id₁ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ (Σ U (λ x → V)) (λ x → W)} → rl-assoc-× (lr-assoc-× a) ≡ a
   aux {(u , v) , w} = refl

   aux' : {a : Σ (Σ U (λ x → V)) (λ x → W)} → (λ z → Fα {V}{W}{X}{Y}{U}{Z} a (Fα-inv (lr-assoc-× a) z)) ≡ (λ y → y)
   aux' {(u , v), w} = ext-set aux''
    where
      aux'' : {a : Σ (Σ X (λ x → Y)) (λ x → Z)} → Fα ((u , v) , w) (Fα-inv (u , v , w) a) ≡ a
      aux'' {(x , y) , z} = refl

α⊗-id₂ : ∀{A B C} → (α⊗-inv {A}{B}{C}) ○ α⊗ ≡h id
α⊗-id₂ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ U (λ x → Σ V (λ x₁ → W))} → lr-assoc-× (rl-assoc-× a) ≡ a
   aux {u , (v , w)} = refl
   aux' : {a : Σ U (λ x → Σ V (λ x₁ → W))} → (λ z → Fα-inv {_}{U}{V}{W}{X}{Y}{Z} a (Fα (rl-assoc-× a) z)) ≡ (λ y → y)
   aux' {u , (v , w)} = ext-set aux''
    where
      aux'' : {a : Σ X (λ x → Σ Y (λ x₁ → Z))} → Fα-inv (u , v , w) (Fα ((u , v) , w) a) ≡ a
      aux'' {x , (y , z)} = refl

-- Internal hom:
⊸-cond : ∀{U V X Y : Set}{α : U → X → Set}{β : V → Y → Set}
  → Σ (U → V) (λ x → U → Y → X)
  → Σ U (λ x → Y)
  → Set
⊸-cond {α = α}{β} (f , F) (u , y) = α u (F u y) → β (f u) y

_⊸ₒ_ : Obj → Obj → Obj
(U , X , α) ⊸ₒ (V , Y , β) = ((U → V) × (U → Y → X)) , ((U × Y) , ⊸-cond {α = α}{β})

_⊸ₐ_ : {A B C D : Obj} → Hom C A → Hom B D → Hom (A ⊸ₒ B) (C ⊸ₒ D)
_⊸ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) =
  h , H , cond
 where
  h : Σ (U → V) (λ x → U → Y → X) → Σ (W → S) (λ x → W → T → Z)
  h (i , I) = (λ w → g (i (f w))) , (λ w t → F w (I (f w) (G (i (f w)) t)))
  H : Σ (U → V) (λ x → U → Y → X) → Σ W (λ x → T) → Σ U (λ x → Y)
  H (i , I) (w , t) = f w , G (i (f w)) t
  cond : {u : Σ (U → V) (λ x → U → Y → X)} {y : Σ W (λ x → T)} → ⊸-cond {α = α}{β} u (H u y) → ⊸-cond {α = γ}{δ} (h u) y
  cond {i , I}{w , y} p₃ p₄ = p₂ (p₃ (p₁ p₄))

cur : {A B C : Obj}
  → Hom (A ⊗ₒ B) C
  → Hom A (B ⊸ₒ C)
cur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ u → (λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) , (λ u r → fst (F (u , (fst r)) (snd r))) , cond
 where
   cond : {u : U} {y : Σ V (λ x → Z)}
     → α u (fst (F (u , fst y) (snd y)))
     → ⊸-cond {α = β}{γ} ((λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) y
   cond {u}{v , z} p₂ p₃ with (p₁ {u , v}{z})
   ... | p₄ with F (u , v) z
   ... | (x , y) = p₄ (p₂ , p₃)

cur-≡h : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C}
  → f₁ ≡h f₂
  → cur f₁ ≡h cur f₂
cur-≡h {U , X , α}{V , Y , β}{W , Z , γ}
       {f₁ , F₁ , p₁}{f₂ , F₂ , p₂} (p₃ , p₄)
       rewrite p₃ | p₄ = refl , refl

cur-cong : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C} → f₁ ≡h f₂ → cur f₁ ≡h cur f₂
cur-cong {(U , X , α)} {(V , Y , β)} {(W , Z , γ)}{f₁ , F₁ , _}{f₂ , F₂ , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

uncur : {A B C : Obj}
  → Hom A (B ⊸ₒ C)
  → Hom (A ⊗ₒ B) C
uncur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = let h = λ r → fst (f (fst r)) (snd r)
        H = λ r z → F (fst r) (snd r , z) , snd (f (fst r)) (snd r) z
     in h , (H , cond)
 where
  cond : {u : Σ U (λ x → V)} {y : Z} →
      (α ⊗ᵣ β) u (F (fst u) (snd u , y) , snd (f (fst u)) (snd u) y) →
      γ (fst (f (fst u)) (snd u)) y
  cond {u , v}{z} (p₂ , p₃) with p₁ {u} {v , z}
  ... | p₄ with f u
  ... | i , I = p₄ p₂ p₃

cur-uncur-bij₁ : ∀{A B C}{f : Hom (A ⊗ₒ B) C}
  → uncur (cur f) ≡h f
cur-uncur-bij₁ {U , X , α}{V , Y , β}{W , Z , γ}{f , F , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : Σ U (λ x → V)} → f (fst a , snd a) ≡ f a
   aux₁ {u , v} = refl
   aux₂ : {a : Σ U (λ x → V)} → (λ z → fst (F (fst a , snd a) z) , snd (F (fst a , snd a) z)) ≡ F a
   aux₂ {u , v} = ext-set aux₃
    where
      aux₃ : {a : Z} → (fst (F (u , v) a) , snd (F (u , v) a)) ≡ F (u , v) a
      aux₃ {z} with F (u , v) z
      ... | x , y = refl

cur-uncur-bij₂ : ∀{A B C}{g : Hom A (B ⊸ₒ C)}
  → cur (uncur g) ≡h g
cur-uncur-bij₂ {U , X , α}{V , Y , β}{W , Z , γ}{g , G , p₁} = (ext-set aux) , ext-set (ext-set aux')
 where
  aux : {a : U} → ((λ v → fst (g a) v) , (λ v z → snd (g a) v z)) ≡ g a
  aux {u} with g u
  ... | i , I = refl
  aux' : {u : U}{r : Σ V (λ x → Z)} → G u (fst r , snd r) ≡ G u r
  aux' {u}{v , z} = refl
{-
-- The of-course exponential:
!ₒ-cond : ∀{U X : Set}
  → (U → X → Set)
  → U
  → (U → X *)
  → Set
!ₒ-cond α u f = all-pred (α u) (f u)

!ₒ : Obj → Obj
!ₒ (U , X , α) = U , (U → X *) , !ₒ-cond α

!-cta : {V Y U X : Set}
  → (Y → X)
  → (U → V)
  → (V → Y *)
  → (U → X *)
!-cta F f g = λ u → list-funct F (g (f u))

!ₐ-cond : ∀{U V Y X : Set}{F : Y → X}{f : U → V}
  → (α : U → X → Set)
  → (β : V → Y → Set)
  → (p : {u : U} {y : Y} → α u (F y) → β (f u) y)
    {u : U}{l : Y *}
  → all-pred (α u) (list-funct F l)
  → all-pred (β (f u)) l
!ₐ-cond _ _ _ {l = []} _ = triv
!ₐ-cond α β p {u}{x :: xs} (p' , p'') = p p' , !ₐ-cond α β p p''

!ₐ : {A B : Obj} → Hom A B → Hom (!ₒ A) (!ₒ B)
!ₐ {U , X , α}{V , Y , β} (f , F , p) = f , !-cta F f , !ₐ-cond α β p

-- Of-course is a comonad:
ε : ∀{A} → Hom (!ₒ A) A
ε {U , X , α} = id-set , (λ x y → [ x ]) , fst

δ-cta : {U X : Set} → (U → 𝕃 (U → 𝕃 X)) → U → 𝕃 X
δ-cta g u = foldr (λ f rest → (f u) ++ rest) [] (g u)

δ : ∀{A} → Hom (!ₒ A) (!ₒ (!ₒ A))
δ {U , X , α} = id-set , δ-cta , δ-cond
  where
   δ-cond : {u : U} {l : 𝕃 (U → 𝕃 X)}
     → all-pred (α u) (foldr (λ f → _++_ (f u)) [] l)
     → all-pred (λ f
     → all-pred (α u) (f u)) l
   δ-cond {l = []} _ = triv
   δ-cond {u}{l = x :: l'} p with
     all-pred-append {X}{α u}
                     {x u}
                     {foldr (λ f → _++_ (f u)) [] l'}
                     ∧-unit ∧-assoc
   ... | p' rewrite p' = fst p , δ-cond {u} {l'} (snd p)

-- These diagrams can be found on page 22 of the report.
comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (!ₐ (δ {A})) ≡h (δ {A}) ○ (δ { !ₒ A})
comonand-diag₁ {U , X , α} =
  refl , ext-set (λ {a} → ext-set (λ {a₁} → aux {a₁}{a a₁}))
 where
   aux : ∀{a₁ : U}{l : 𝕃 (U → 𝕃 (U → 𝕃 X))} →
      foldr (λ f → _++_ (f a₁)) []
      (map (λ g u → foldr (λ f → _++_ (f u)) [] (g u)) l)
      ≡
      foldr (λ f → _++_ (f a₁)) [] (foldr (λ f → _++_ (f a₁)) [] l)
   aux {a}{[]} = refl
   aux {a}{x :: l} rewrite
     sym (foldr-append {l₁ = x a}{foldr (λ f → _++_ (f a)) [] l}{a})
     = cong2 {a = foldr (λ f → _++_ (f a)) [] (x a)}
             _++_
             refl
             (aux {a}{l})

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { !ₒ A}) ≡h (δ {A}) ○ (!ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {f} → ext-set (λ {a} → aux {a}{f a}))
 where
  aux : ∀{a : U}{l : X *}
    → l ++ [] ≡ foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x y → x :: []) l)
  aux {a}{[]} = refl
  aux {a}{x :: l} with aux {a}{l}
  ... | IH rewrite ++[] l =
    cong2 {a = x} {x} {l}
          {foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x₁ y → x₁ :: []) l)} _::_ refl
          IH

module Cartesian where
  π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (U , X , α))
  π₁ {U}{X}{V}{Y}{α}{β} = fst , (λ f → (λ v u → f u) , (λ u v → [])) , π₁-cond
    where
      π₁-cond : ∀{u : Σ U (λ x → V)} {y : U → 𝕃 X} →
        ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
        (λ u₁ f → all-pred (β u₁) (f u₁)))
        u ((λ v u₁ → y u₁) , (λ u₁ v → [])) →
        all-pred (α (fst u)) (y (fst u))
      π₁-cond {u , v}{f} (p₁ , p₂) = p₁

  π₂ : {U X V Y : Set}
      → {α : U → X → Set}
      → {β : V → Y → Set}
      → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (V , Y , β))
  π₂ {U}{X}{V}{Y}{α}{β} = snd , (λ f → (λ v u → []) , (λ u v → f v)) , π₂-cond
      where
        π₂-cond : ∀{u : Σ U (λ x → V)} {y : V → 𝕃 Y} →
          ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
            (λ u₁ f → all-pred (β u₁) (f u₁)))
              u ((λ v u₁ → []) , (λ u₁ v → y v)) →
            all-pred (β (snd u)) (y (snd u))
        π₂-cond {u , v}{f} (p₁ , p₂) = p₂

  cart-ar-crt : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y) → W → 𝕃 Z
  cart-ar-crt  (f , F , p₁) (g , G , p₂) (j₁ , j₂) w = F (j₁ (g w)) w ++ G (j₂ (f w)) w

  cart-ar : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Hom (!ₒ (W , Z , γ)) ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))
  cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ} (f , F , p₁) (g , G , p₂)
    = (λ w → f w , g w) , cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) , cart-ar-cond
      where
        cart-ar-cond : ∀{u : W} {y : Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y)} →
          all-pred (γ u) (cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) y u) →
          ((λ u₁ f₁ → all-pred (α u₁) (f₁ u₁)) ⊗ᵣ
          (λ u₁ f₁ → all-pred (β u₁) (f₁ u₁)))
          (f u , g u) y
        cart-ar-cond {w}{j₁ , j₂} p
          rewrite
            all-pred-append {f = γ w}{F (j₁ (g w)) w}{G (j₂ (f w)) w} ∧-unit ∧-assoc with p
        ... | (a , b) = p₁ a , p₂ b

  cart-diag₁ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (U , X , α)}
      (!ₐ {W , Z , γ}{U , X , α} f)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (U , X , α)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₁)
  cart-diag₁ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → sym (++[] (map F (j (f w))))))

  cart-diag₂ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (V , Y , β)}
      (!ₐ {W , Z , γ}{V , Y , β} g)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (V , Y , β)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₂)
  cart-diag₂ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → refl))
-}

-----------------------------------------------------------------------
-- This file defines DC₂(Sets) and its SMC structure.              --
-----------------------------------------------------------------------
module DC2Sets where

open import prelude

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (U → X → Set))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , α) (V , Y , β) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , α)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , α)}{(V , Y , β)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , α}{V , Y , β}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , α}{V , Y , β}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , α}{V , Y , β}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , α}
         {V , Y , β}
         {W , Z , γ}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , α}{V , Y , β}{W , Z , γ}{S , T , ι}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _}{V , Y , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _}{V , Y , _}{f , F , _} = refl , refl

-----------------------------------------------------------------------
-- DC₂(Sets) is a SMC                                              --
-----------------------------------------------------------------------

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , α) ⊗ₒ (V , Y , β) = ((U × V) , (X × Y) , α ⊗ᵣ β)

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

-- The unit for tensor:
ι : ⊤ → ⊤ → Set
ι triv triv = ⊤

I : Obj
I = (⊤ , ⊤ , ι)

J : Obj
J = (⊤ , ⊤ , (λ x y → ⊥))

-- The left-unitor:
λ⊗-p : ∀{U X α}{u : Σ ⊤ (λ x → U)} {y : X} → (ι ⊗ᵣ α) u (triv , y) → α (snd u) y
λ⊗-p {U}{X}{α}{(triv , u)}{x} = snd

λ⊗ : ∀{A : Obj} → Hom (I ⊗ₒ A) A
λ⊗ {(U , X , α)} = snd , (λ _ x → triv , x) , λ⊗-p

λ⊗-inv : ∀{A : Obj} → Hom A (I ⊗ₒ A)
λ⊗-inv {(U , X , α)} = (λ u → triv , u) , (λ _ r → snd r) , λ⊗-inv-p
 where
  λ⊗-inv-p : ∀{U X α}{u : U} {y : Σ ⊤ (λ x → X)} → α u (snd y) → (ι ⊗ᵣ α) (triv , u) y
  λ⊗-inv-p {U}{X}{α}{u}{triv , x} p = triv , p

-- The right-unitor:
ρ⊗ : ∀{A : Obj} → Hom (A ⊗ₒ I) A
ρ⊗ {(U , X , α)} = fst , (λ r x → x , triv) , ρ⊗-p
 where
  ρ⊗-p : ∀{U X α}{u : Σ U (λ x → ⊤)} {y : X} → (α ⊗ᵣ ι) u (y , triv) → α (fst u) y
  ρ⊗-p {U}{X}{α}{(u , _)}{x} (p , _) = p

ρ⊗-inv : ∀{A : Obj} → Hom A (A ⊗ₒ I)
ρ⊗-inv {(U , X , α)} = (λ u → u , triv) , (λ u r → fst r) , ρ⊗-p-inv
 where
  ρ⊗-p-inv : ∀{U X α}{u : U} {y : Σ X (λ x → ⊤)} → α u (fst y) → (α ⊗ᵣ ι) (u , triv) y
  ρ⊗-p-inv {U}{X}{α}{u}{x , triv} p = p , triv

-- Symmetry:
β⊗ : ∀{A B : Obj} → Hom (A ⊗ₒ B) (B ⊗ₒ A)
β⊗ {(U , X , α)}{(V , Y , β)} = twist-× , (λ r₁ r₂ → twist-× r₂) , β⊗-p
 where
   β⊗-p : ∀{U V Y X α β}{u : Σ U (λ x → V)} {y : Σ Y (λ x → X)} → (α ⊗ᵣ β) u (twist-× y) → (β ⊗ᵣ α) (twist-× u) y
   β⊗-p {U}{V}{Y}{X}{α}{β}{u , v}{y , x} = twist-×

-- The associator:
Fα-inv : ∀{ℓ}{U V W X Y Z : Set ℓ} → (U × (V × W)) → ((X × Y) × Z) → (X × (Y × Z))
Fα-inv (u , (v , w)) ((x , y) , z) = x , y , z

α⊗-inv : ∀{A B C : Obj} → Hom (A ⊗ₒ (B ⊗ₒ C)) ((A ⊗ₒ B) ⊗ₒ C)
α⊗-inv {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = rl-assoc-× , Fα-inv , α-inv-cond
 where
   α-inv-cond : {u : Σ U (λ x → Σ V (λ x₁ → W))}{y : Σ (Σ X (λ x → Y)) (λ x → Z)}
     → (α ⊗ᵣ (β ⊗ᵣ γ)) u (Fα-inv u y)
     → ((α ⊗ᵣ β) ⊗ᵣ γ) (rl-assoc-× u) y
   α-inv-cond {u , (v , w)}{(x , y) , z} (p₁ , (p₂ , p₃)) = (p₁ , p₂) , p₃

Fα : ∀{V W X Y U Z : Set} → ((U × V) × W) → (X × (Y × Z)) → ((X × Y) × Z)
Fα {V}{W}{X}{Y}{U}{Z} ((u , v) , w) (x , (y , z)) = (x , y) , z

α⊗ : ∀{A B C : Obj} → Hom ((A ⊗ₒ B) ⊗ₒ C) (A ⊗ₒ (B ⊗ₒ C))
α⊗ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = (lr-assoc-× , Fα , α-cond)
 where
  α-cond : {u : Σ (Σ U (λ x → V)) (λ x → W)}
      {y : Σ X (λ x → Σ Y (λ x₁ → Z))} →
      ((α ⊗ᵣ β) ⊗ᵣ γ) u (Fα u y) → (α ⊗ᵣ (β ⊗ᵣ γ)) (lr-assoc-× u) y
  α-cond {(u , v) , w}{x , (y , z)} ((p₁ , p₂) , p₃) = p₁ , p₂ , p₃

α⊗-id₁ : ∀{A B C} → (α⊗ {A}{B}{C}) ○ α⊗-inv ≡h id
α⊗-id₁ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ (Σ U (λ x → V)) (λ x → W)} → rl-assoc-× (lr-assoc-× a) ≡ a
   aux {(u , v) , w} = refl

   aux' : {a : Σ (Σ U (λ x → V)) (λ x → W)} → (λ z → Fα {V}{W}{X}{Y}{U}{Z} a (Fα-inv (lr-assoc-× a) z)) ≡ (λ y → y)
   aux' {(u , v), w} = ext-set aux''
    where
      aux'' : {a : Σ (Σ X (λ x → Y)) (λ x → Z)} → Fα ((u , v) , w) (Fα-inv (u , v , w) a) ≡ a
      aux'' {(x , y) , z} = refl

α⊗-id₂ : ∀{A B C} → (α⊗-inv {A}{B}{C}) ○ α⊗ ≡h id
α⊗-id₂ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ U (λ x → Σ V (λ x₁ → W))} → lr-assoc-× (rl-assoc-× a) ≡ a
   aux {u , (v , w)} = refl
   aux' : {a : Σ U (λ x → Σ V (λ x₁ → W))} → (λ z → Fα-inv {_}{U}{V}{W}{X}{Y}{Z} a (Fα (rl-assoc-× a) z)) ≡ (λ y → y)
   aux' {u , (v , w)} = ext-set aux''
    where
      aux'' : {a : Σ X (λ x → Σ Y (λ x₁ → Z))} → Fα-inv (u , v , w) (Fα ((u , v) , w) a) ≡ a
      aux'' {x , (y , z)} = refl

-- Internal hom:
⊸-cond : ∀{U V X Y : Set}{α : U → X → Set}{β : V → Y → Set}
  → Σ (U → V) (λ x → U → Y → X)
  → Σ U (λ x → Y)
  → Set
⊸-cond {α = α}{β} (f , F) (u , y) = α u (F u y) → β (f u) y

_⊸ₒ_ : Obj → Obj → Obj
(U , X , α) ⊸ₒ (V , Y , β) = ((U → V) × (U → Y → X)) , ((U × Y) , ⊸-cond {α = α}{β})

_⊸ₐ_ : {A B C D : Obj} → Hom C A → Hom B D → Hom (A ⊸ₒ B) (C ⊸ₒ D)
_⊸ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) =
  h , H , cond
 where
  h : Σ (U → V) (λ x → U → Y → X) → Σ (W → S) (λ x → W → T → Z)
  h (i , I) = (λ w → g (i (f w))) , (λ w t → F w (I (f w) (G (i (f w)) t)))
  H : Σ (U → V) (λ x → U → Y → X) → Σ W (λ x → T) → Σ U (λ x → Y)
  H (i , I) (w , t) = f w , G (i (f w)) t
  cond : {u : Σ (U → V) (λ x → U → Y → X)} {y : Σ W (λ x → T)} → ⊸-cond {α = α}{β} u (H u y) → ⊸-cond {α = γ}{δ} (h u) y
  cond {i , I}{w , y} p₃ p₄ = p₂ (p₃ (p₁ p₄))

cur : {A B C : Obj}
  → Hom (A ⊗ₒ B) C
  → Hom A (B ⊸ₒ C)
cur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ u → (λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) , (λ u r → fst (F (u , (fst r)) (snd r))) , cond
 where
   cond : {u : U} {y : Σ V (λ x → Z)}
     → α u (fst (F (u , fst y) (snd y)))
     → ⊸-cond {α = β}{γ} ((λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) y
   cond {u}{v , z} p₂ p₃ with (p₁ {u , v}{z})
   ... | p₄ with F (u , v) z
   ... | (x , y) = p₄ (p₂ , p₃)

cur-≡h : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C}
  → f₁ ≡h f₂
  → cur f₁ ≡h cur f₂
cur-≡h {U , X , α}{V , Y , β}{W , Z , γ}
       {f₁ , F₁ , p₁}{f₂ , F₂ , p₂} (p₃ , p₄)
       rewrite p₃ | p₄ = refl , refl

cur-cong : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C} → f₁ ≡h f₂ → cur f₁ ≡h cur f₂
cur-cong {(U , X , α)} {(V , Y , β)} {(W , Z , γ)}{f₁ , F₁ , _}{f₂ , F₂ , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

uncur : {A B C : Obj}
  → Hom A (B ⊸ₒ C)
  → Hom (A ⊗ₒ B) C
uncur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = h , (H , cond)
  where
  h : Σ U (λ x → V) → W
  h (u , v) with f u
  ... | i , I = i v
  H : Σ U (λ x → V) → Z → Σ X (λ x → Y)
  H (u , v) z with f u
  ... | i , I = F u (v , z) , I v z
  cond : {u : Σ U (λ x → V)} {z : Z} → (α ⊗ᵣ β) u (H u z) → γ (h u) z
  cond {u , v}{z} r with (p₁ {u}{v , z})
  ... | p₄ with f u
  ... | i , I with r
  ... | p₂ , p₃ = p₄ p₂ p₃

{-
cur-uncur-bij₁ : ∀{A B C}{f : Hom (A ⊗ₒ B) C}
  → uncur (cur f) ≡h f
cur-uncur-bij₁ {U , X , α}{V , Y , β}{W , Z , γ}{f , F , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : Σ U (λ x → V)} → f (fst a , snd a) ≡ f a
   aux₁ {u , v} = refl

   aux₂ : {a : Z} → ((λ v → fst (F a) v) , (λ u → snd (F a) u)) ≡ F a
   aux₂ {z} with F z
   ... | j₁ , j₂ = refl

cur-uncur-bij₂ : ∀{A B C}{g : Hom A (B ⊸ₒ C)}
  → cur (uncur g) ≡h g
cur-uncur-bij₂ {U , X , α}{V , Y , β}{W , Z , γ}{g , G , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : U} → ((λ v → fst (g a) v) , (λ z → snd (g a) z)) ≡ g a
   aux₁ {u} with g u
   ... | (j₁ , j₂) = refl

   aux₂ : {a : Σ V (λ x → Z)} → G (fst a , snd a) ≡ G a
   aux₂ {v , z} = refl

-- The of-course exponential:
!ₒ-cond : ∀{U X : Set}
  → (U → X → Set)
  → U
  → (U → X *)
  → Set
!ₒ-cond α u f = all-pred (α u) (f u)

!ₒ : Obj → Obj
!ₒ (U , X , α) = U , (U → X *) , !ₒ-cond α

!-cta : {V Y U X : Set}
  → (Y → X)
  → (U → V)
  → (V → Y *)
  → (U → X *)
!-cta F f g = λ u → list-funct F (g (f u))

!ₐ-cond : ∀{U V Y X : Set}{F : Y → X}{f : U → V}
  → (α : U → X → Set)
  → (β : V → Y → Set)
  → (p : {u : U} {y : Y} → α u (F y) → β (f u) y)
    {u : U}{l : Y *}
  → all-pred (α u) (list-funct F l)
  → all-pred (β (f u)) l
!ₐ-cond _ _ _ {l = []} _ = triv
!ₐ-cond α β p {u}{x :: xs} (p' , p'') = p p' , !ₐ-cond α β p p''

!ₐ : {A B : Obj} → Hom A B → Hom (!ₒ A) (!ₒ B)
!ₐ {U , X , α}{V , Y , β} (f , F , p) = f , !-cta F f , !ₐ-cond α β p

-- Of-course is a comonad:
ε : ∀{A} → Hom (!ₒ A) A
ε {U , X , α} = id-set , (λ x y → [ x ]) , fst

δ-cta : {U X : Set} → (U → 𝕃 (U → 𝕃 X)) → U → 𝕃 X
δ-cta g u = foldr (λ f rest → (f u) ++ rest) [] (g u)

δ : ∀{A} → Hom (!ₒ A) (!ₒ (!ₒ A))
δ {U , X , α} = id-set , δ-cta , δ-cond
  where
   δ-cond : {u : U} {l : 𝕃 (U → 𝕃 X)}
     → all-pred (α u) (foldr (λ f → _++_ (f u)) [] l)
     → all-pred (λ f
     → all-pred (α u) (f u)) l
   δ-cond {l = []} _ = triv
   δ-cond {u}{l = x :: l'} p with
     all-pred-append {X}{α u}
                     {x u}
                     {foldr (λ f → _++_ (f u)) [] l'}
                     ∧-unit ∧-assoc
   ... | p' rewrite p' = fst p , δ-cond {u} {l'} (snd p)

-- These diagrams can be found on page 22 of the report.
comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (!ₐ (δ {A})) ≡h (δ {A}) ○ (δ { !ₒ A})
comonand-diag₁ {U , X , α} =
  refl , ext-set (λ {a} → ext-set (λ {a₁} → aux {a₁}{a a₁}))
 where
   aux : ∀{a₁ : U}{l : 𝕃 (U → 𝕃 (U → 𝕃 X))} →
      foldr (λ f → _++_ (f a₁)) []
      (map (λ g u → foldr (λ f → _++_ (f u)) [] (g u)) l)
      ≡
      foldr (λ f → _++_ (f a₁)) [] (foldr (λ f → _++_ (f a₁)) [] l)
   aux {a}{[]} = refl
   aux {a}{x :: l} rewrite
     sym (foldr-append {l₁ = x a}{foldr (λ f → _++_ (f a)) [] l}{a})
     = cong2 {a = foldr (λ f → _++_ (f a)) [] (x a)}
             _++_
             refl
             (aux {a}{l})

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { !ₒ A}) ≡h (δ {A}) ○ (!ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {f} → ext-set (λ {a} → aux {a}{f a}))
 where
  aux : ∀{a : U}{l : X *}
    → l ++ [] ≡ foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x y → x :: []) l)
  aux {a}{[]} = refl
  aux {a}{x :: l} with aux {a}{l}
  ... | IH rewrite ++[] l =
    cong2 {a = x} {x} {l}
          {foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x₁ y → x₁ :: []) l)} _::_ refl
          IH

module Cartesian where
  π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (U , X , α))
  π₁ {U}{X}{V}{Y}{α}{β} = fst , (λ f → (λ v u → f u) , (λ u v → [])) , π₁-cond
    where
      π₁-cond : ∀{u : Σ U (λ x → V)} {y : U → 𝕃 X} →
        ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
        (λ u₁ f → all-pred (β u₁) (f u₁)))
        u ((λ v u₁ → y u₁) , (λ u₁ v → [])) →
        all-pred (α (fst u)) (y (fst u))
      π₁-cond {u , v}{f} (p₁ , p₂) = p₁

  π₂ : {U X V Y : Set}
      → {α : U → X → Set}
      → {β : V → Y → Set}
      → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (V , Y , β))
  π₂ {U}{X}{V}{Y}{α}{β} = snd , (λ f → (λ v u → []) , (λ u v → f v)) , π₂-cond
      where
        π₂-cond : ∀{u : Σ U (λ x → V)} {y : V → 𝕃 Y} →
          ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
            (λ u₁ f → all-pred (β u₁) (f u₁)))
              u ((λ v u₁ → []) , (λ u₁ v → y v)) →
            all-pred (β (snd u)) (y (snd u))
        π₂-cond {u , v}{f} (p₁ , p₂) = p₂

  cart-ar-crt : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y) → W → 𝕃 Z
  cart-ar-crt  (f , F , p₁) (g , G , p₂) (j₁ , j₂) w = F (j₁ (g w)) w ++ G (j₂ (f w)) w

  cart-ar : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Hom (!ₒ (W , Z , γ)) ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))
  cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ} (f , F , p₁) (g , G , p₂)
    = (λ w → f w , g w) , cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) , cart-ar-cond
      where
        cart-ar-cond : ∀{u : W} {y : Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y)} →
          all-pred (γ u) (cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) y u) →
          ((λ u₁ f₁ → all-pred (α u₁) (f₁ u₁)) ⊗ᵣ
          (λ u₁ f₁ → all-pred (β u₁) (f₁ u₁)))
          (f u , g u) y
        cart-ar-cond {w}{j₁ , j₂} p
          rewrite
            all-pred-append {f = γ w}{F (j₁ (g w)) w}{G (j₂ (f w)) w} ∧-unit ∧-assoc with p
        ... | (a , b) = p₁ a , p₂ b

  cart-diag₁ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (U , X , α)}
      (!ₐ {W , Z , γ}{U , X , α} f)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (U , X , α)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₁)
  cart-diag₁ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → sym (++[] (map F (j (f w))))))

  cart-diag₂ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (V , Y , β)}
      (!ₐ {W , Z , γ}{V , Y , β} g)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (V , Y , β)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₂)
  cart-diag₂ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → refl))
-}


Ensure README.agda imports everything (fix #41)

This was broken in 49e8b38c23e9c250b738a0ddba6384e6268034bd, so add a
comment explaining why that line needs to be there.

I verified that the code still typechecks on my machine.

Old-commit-hash: 36ff398aab5149e6b6845d2c6ea1f05ab8d97bf8

module README where

----------------------------
-- INCREMENTAL λ-CALCULUS --
----------------------------
--
--
-- IMPORTANT FILES
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda formalization.
--
-- PLDI14-List-of-Theorems.agda
--   For each theorem, lemma or definition in the PLDI 2014 submission,
--   it points to the corresponding Agda object.
--
--
-- LOCATION OF AGDA MODULES
--
-- To find the file containing an Agda module, replace the dots in its
-- full name by directory separators. The result is the file's path relative
-- to this directory. For example, Parametric.Syntax.Type is defined in
-- Parametric/Syntax/Type.agda.
--
--
-- HOW TO TYPE CHECK EVERYTHING
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda, the Agda standard library (version 0.7), generate Everything.agda
-- with the attached Haskell helper, and finally run Agda on this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- We use Agda HEAD from September 2013; Agda 2.3.2.1 might happen to work, but
-- has some bugs with serialization of code using some recent syntactic sugar
-- which we use (https://code.google.com/p/agda/issues/detail?id=756), so it
-- might work or not. When it does not, removing Agda caches (.agdai files)
-- appears to often help. You can use "find . -name '*.agdai' | xargs rm" to do
-- that.

import Postulate.Extensionality

import Base.Data.DependentList

-- Variables and contexts
import Base.Syntax.Context

-- Sets of variables
import Base.Syntax.Vars

import Base.Denotation.Notation

-- Environments
import Base.Denotation.Environment

-- Change contexts
import Base.Change.Context

-- # Base, parametric proof.
--
-- This is for a parametric calculus where:
-- types are parametric in base types
-- terms are parametric in constants
--
--
-- Modules are ordered and grouped according to what they represent.

-- ## Definitions

import Parametric.Syntax.Type
import Parametric.Syntax.Term

import Parametric.Denotation.Value
import Parametric.Denotation.Evaluation

import Parametric.Change.Type
import Parametric.Change.Term

import Parametric.Change.Derive

import Parametric.Change.Value
import Parametric.Change.Evaluation

-- ## Proofs

import Parametric.Change.Validity
import Parametric.Change.Specification
import Parametric.Change.Implementation
import Parametric.Change.Correctness

-- # Nehemiah plugin
--
-- The structure is the same as the parametric proof (down to the
-- order and the grouping of modules), except for the postulate module.

-- Postulate an abstract data type for integer Bags.
import Postulate.Bag-Nehemiah

-- ## Definitions
import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation

import Nehemiah.Change.Term
import Nehemiah.Change.Type

import Nehemiah.Change.Derive

import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- ## Proofs

import Nehemiah.Change.Validity
import Nehemiah.Change.Specification
import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness

-- Import everything else. This ensures that typechecking README.agda typechecks
-- the entire codebase, because Everything.agda is auto-generated.
import Everything


… is now called it

… is now called it

{-# OPTIONS --without-K #-}
open import Level
open import Type hiding (★)

module Function.InstanceArguments where

explicitize : ∀ {a b} {A : ★ a} {B : A → ★ b} →
                (⦃ x : A ⦄ → B x) → (x : A) → B x
explicitize f x = f ⦃ x ⦄

it : ∀ {a} {A : ★ a} ⦃ x : A ⦄ → A
it ⦃ x ⦄ = x

{-# OPTIONS --without-K #-}
open import Level
open import Type hiding (★)

module Function.InstanceArguments where

explicitize : ∀ {a b} {A : ★ a} {B : A → ★ b} →
                (⦃ x : A ⦄ → B x) → (x : A) → B x
explicitize f x = f ⦃ x ⦄

… : ∀ {a} {A : ★ a} ⦃ x : A ⦄ → A
… ⦃ x ⦄ = x


working on contextual dynamics transcription

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  -- used to mark which dhexp holes have been evaluated
  data mark : Set where
    ✓ : mark
    ✗ : mark

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst × mark) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst × mark) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- todo: this probably belongs in contexts, but need to abstract it.
  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × (tctx × htyp))
  u ::[ Γ ] τ = u , (Γ , τ)

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts?
  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ1 τ2 Δ2} →
                -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) (xd∈σ : (x , d) ∈ σ) →
            Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ m} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ , m ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ m} →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ , m ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    ·λ_[_]_ : Nat → htyp → ectx → ectx
    _∘₁_ : dhexp → ectx → ectx
    _∘₂_ : ectx → dhexp → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst × mark) → ectx
    <_>_   : htyp → ectx → ectx

  -- instruction transition judgement
  data _⊢_→>_ : (Δ : hctx) (d d' : dhexp) → Set where
    ITLam : ∀{ Δ x τ d1 d2 } →
            d2 final →
            Δ ⊢ ((·λ x [ τ ] d1) ∘ d2) →> ([ ■ (x , d2) ] d1) -- this is very unlikely to work long term
    ITCast : ∀{d Δ τ1 τ2 } →
             d final →
             Δ , ∅ ⊢ d :: τ2 →
             τ1 ~ τ2 → -- maybe?
             Δ ⊢ < τ1 > d →> d -- is that the right thing to step to?

  data _ectxt : (ε : ectx) → Set where
    ECDot : ⊙ ectxt
    ECLam : ∀{ε x τ} →
            ε ectxt →
            (·λ x [ τ ] ε) ectxt
    ECAp1 : ∀{d ε} →
            d final →
            ε ectxt →
            (d ∘₁ ε) ectxt
    ECAp2 : ∀{d ε} →
            ε ectxt →
            (ε ∘₂ d) ectxt
    ECNEHole : ∀{ε m u σ} →
               ε ectxt →
               (⦇ ε ⦈⟨ u , σ , m ⟩) ectxt
    ECCast : ∀{ ε τ } →
             ε ectxt →
             (< τ > ε ) ectxt

  -- d is result of filling the hole in ε with d'
  data _==_[_] : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FRefl : ∀{d : dhexp} →
            d == ⊙ [ d ]
    -- FLam : ∀{ d d1 ε x τ } →
    --        d1 == ε [ d ] →
    --        (·λ x [ τ ] d1) == ?
    -- FAp1 :
    -- FAp2 :
    -- FNEHole : ∀{ d d1 ε τ } →
    --        d1 == ε [ d ] →
    --        (⦇ d1 ⦈⟨ u , σ , m⟩) == ⦇ d ⦈⟨ u , σ , m⟩
    FCast : ∀{ d d1 ε τ } →
           d1 == ε [ d ] →
           (< τ > d1) == < τ > ε [ d ]

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε [ d0 ] →
           Δ ⊢ d0 →> d0' → -- should this Δ be ∅?
           d' == ε [ d0' ] → -- why is this the same ε
           Δ ⊢ d ↦ d

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  -- used to mark which dhexp holes have been evaluated
  data mark : Set where
    ✓ : mark
    ✗ : mark

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst × mark) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst × mark) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- todo: this probably belongs in contexts, but need to abstract it.
  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × (tctx × htyp))
  u ::[ Γ ] τ = u , (Γ , τ)

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts?
  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ1 τ2 Δ2} →
                -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) (xd∈σ : (x , d) ∈ σ) →
            Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ m} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ , m ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ m} →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ , m ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈⟨ u , σ ⟩ ↦  ⦇ d' ⦈⟨ u , σ ⟩
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)


Add classification

Add classification

data Bool : Set where
  true  : Bool
  false : Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

apply : {A B : Set} → (A → B) → List A → List B
apply _ ∘        = ∘
apply f (x ∷ xs) = (f x) ∷ (apply f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

data Bool : Set where
  true  : Bool
  false : Bool

_or_ : Bool → Bool → Bool
true or true   = true
true or false  = true
false or true  = true
false or false = false

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

apply : {A B : Set} → (A → B) → List A → List B
apply _ ∘        = ∘
apply f (x ∷ xs) = (f x) ∷ (apply f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_,_,_¬⊨_ : List Separation → List Arrow → List ℕ → ℕ → Bool
--(m ∷ ms) , cs , ps ¬⊨ n    with (modelsupports m cs

_,_¬⊨_ : List Separation → List Arrow → Arrow → Bool


Added an example.

Added an example.

Ignore-this: 985eb6502f1fc33826fd4223f222a769

darcs-hash:20100804170305-3bd4e-7fc9f285102f43cb8694ff2077dff0badde0cd3f.gz

------------------------------------------------------------------------------
-- Arithmetic properties (using induction on the LTC natural numbers)
------------------------------------------------------------------------------

module LTC.Data.Nat.PropertiesByInduction where

open import LTC.Minimal

open import LTC.Data.Nat

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

-- Usually our proofs use pattern matching instead of the induction
-- principle associated with the LTC natural numbers. The following
-- example shows a proof using it.

-- Proof without use definitions
+-assocND : {m n o : D} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assocND {n = n} {o} Nm _ _ = indN P P0 iStep Nm
  where
    P : D → Set
    P i = i + n + o ≡ i + (n + o)

    postulate
      P0 : zero + n + o ≡ zero + (n + o)
    {-# ATP prove P0 #-} -- We use the ATP systems to prove the base case.

    postulate
      iStep : {i : D} → N i →
              i + n + o ≡ i + (n + o) → -- IH.
              succ i + n + o ≡ succ i + (n + o)
    {-# ATP prove iStep #-} -- We use the ATP systems to prove the
                            -- induction step.

-- Proof using definitions
+-assocD : {m n o : D} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assocD {n = n} {o} Nm _ _ = indN P P0 iStep Nm
  where
    P : D → Set
    P i = i + n + o ≡ i + (n + o)
    {-# ATP definition P #-}

    postulate
      P0 : P zero
    {-# ATP prove P0 #-} -- We use the ATP systems to prove the base case.

    postulate
      iStep : {i : D} → N i → P i → P (succ i)
    {-# ATP prove iStep #-} -- We use the ATP systems to prove the
                            -- induction step.

------------------------------------------------------------------------------
-- Arithmetic properties (using induction on the LTC natural numbers)
------------------------------------------------------------------------------

module LTC.Data.Nat.PropertiesByInduction where

open import LTC.Minimal

open import LTC.Data.Nat

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

-- Usually our proofs use pattern matching instead of the induction
-- principle associated with the LTC natural numbers. The following
-- example shows a proof using it.
+-assoc : {m n o : D} → N m → N n → N o → (m + n) + o ≡ m + (n + o)
+-assoc {m} {n} {o} Nm Nn No = indN P P0 iStep Nm
  where
    P : D → Set
    P i = i + n + o ≡ i + (n + o)

    postulate
      P0 : zero + n + o ≡ zero + (n + o)
    {-# ATP prove P0 #-} -- We use the ATP systems to prove the base case.

    postulate
      iStep : {i : D} → N i →
              i + n + o ≡ i + (n + o) → -- IH.
              succ i + n + o ≡ succ i + (n + o)
    {-# ATP prove iStep #-} -- We use the ATP systems to prove the
                            -- induction step.


Document P.C.Value.

Document P.C.Value.

Old-commit-hash: 1a3643a6990f5380e0a80e97aa83d76b6a2e2244

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The values of terms in Parametric.Change.Term.
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Change.Type as ChangeType

module Parametric.Change.Value
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open ChangeType.Structure Base ΔBase

open import Base.Denotation.Notation

-- Extension point 1: The value of ⊕ for base types.
ApplyStructure : Set
ApplyStructure = ∀ ι → ⟦ ι ⟧Base → ⟦ ΔBase ι ⟧Base → ⟦ ι ⟧Base

-- Extension point 2: The value of ⊝ for base types.
DiffStructure : Set
DiffStructure = ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → ⟦ ΔBase ι ⟧Base

module Structure
    (⟦apply-base⟧ : ApplyStructure)
    (⟦diff-base⟧ : DiffStructure)
  where

  -- We provide: The value of ⊕ and ⊝ for arbitrary types.
  ⟦apply⟧ : ∀ τ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  ⟦diff⟧ : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧

  infixl 6 ⟦apply⟧ ⟦diff⟧
  syntax ⟦apply⟧ τ v dv = v ⟦⊕₍ τ ₎⟧ dv
  syntax ⟦diff⟧ τ u v = u ⟦⊝₍ τ ₎⟧ v

  v ⟦⊕₍ base ι ₎⟧ Δv = ⟦apply-base⟧ ι v Δv
  f ⟦⊕₍ σ ⇒ τ ₎⟧ Δf = λ v → f v ⟦⊕₍ τ ₎⟧ Δf v (v ⟦⊝₍ σ ₎⟧ v)

  u ⟦⊝₍ base ι ₎⟧ v = ⟦diff-base⟧ ι u v
  g ⟦⊝₍ σ ⇒ τ ₎⟧ f = λ v Δv → (g (v ⟦⊕₍ σ ₎⟧ Δv)) ⟦⊝₍ τ ₎⟧ (f v)

  _⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _⟦⊕⟧_ {τ} = ⟦apply⟧ τ

  _⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _⟦⊝⟧_ {τ} = ⟦diff⟧ τ

  alternate : ∀ {Γ} → ⟦ Γ ⟧ → ⟦ mapContext ΔType Γ ⟧ → ⟦ ΔContext Γ ⟧
  alternate {∅} ∅ ∅ = ∅
  alternate {τ • Γ} (v • ρ) (dv • dρ) = dv • v • alternate ρ dρ

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Change.Type as ChangeType

module Parametric.Change.Value
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open ChangeType.Structure Base ΔBase

open import Base.Denotation.Notation

-- `diff` and `apply`, without validity proofs

ApplyStructure : Set
ApplyStructure = ∀ ι → ⟦ ι ⟧Base → ⟦ ΔBase ι ⟧Base → ⟦ ι ⟧Base

DiffStructure : Set
DiffStructure = ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → ⟦ ΔBase ι ⟧Base

module Structure
    (⟦apply-base⟧ : ApplyStructure)
    (⟦diff-base⟧ : DiffStructure)
  where

  ⟦apply⟧ : ∀ τ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  ⟦diff⟧ : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧

  infixl 6 ⟦apply⟧ ⟦diff⟧
  syntax ⟦apply⟧ τ v dv = v ⟦⊕₍ τ ₎⟧ dv
  syntax ⟦diff⟧ τ u v = u ⟦⊝₍ τ ₎⟧ v

  v ⟦⊕₍ base ι ₎⟧ Δv = ⟦apply-base⟧ ι v Δv
  f ⟦⊕₍ σ ⇒ τ ₎⟧ Δf = λ v → f v ⟦⊕₍ τ ₎⟧ Δf v (v ⟦⊝₍ σ ₎⟧ v)

  u ⟦⊝₍ base ι ₎⟧ v = ⟦diff-base⟧ ι u v
  g ⟦⊝₍ σ ⇒ τ ₎⟧ f = λ v Δv → (g (v ⟦⊕₍ σ ₎⟧ Δv)) ⟦⊝₍ τ ₎⟧ (f v)

  _⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _⟦⊕⟧_ {τ} = ⟦apply⟧ τ

  _⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _⟦⊝⟧_ {τ} = ⟦diff⟧ τ

  alternate : ∀ {Γ} → ⟦ Γ ⟧ → ⟦ mapContext ΔType Γ ⟧ → ⟦ ΔContext Γ ⟧
  alternate {∅} ∅ ∅ = ∅
  alternate {τ • Γ} (v • ρ) (dv • dρ) = dv • v • alternate ρ dρ


Butcher it so it compiles

Butcher it so it compiles

open import Data.Bool.Base using (Bool)
------------------------------------------------------------------------
-- The Agda standard library
--
-- IO
------------------------------------------------------------------------

open import Coinduction
open import Data.Unit
open import Data.String
open import Data.Colist
open import Function
import IO.Primitive as Prim
open import Level

------------------------------------------------------------------------
-- The IO monad

-- One cannot write "infinitely large" computations with the
-- postulated IO monad in IO.Primitive without turning off the
-- termination checker (or going via the FFI, or perhaps abusing
-- something else). The following coinductive deep embedding is
-- introduced to avoid this problem. Possible non-termination is
-- isolated to the run function below.

infixl 1 _>>=_ _>>_

data IO {a} (A : Set a) : Set (suc a) where
  lift   : (m : Prim.IO A) → IO A
  return : (x : A) → IO A
  _>>=_  : {B : Set a} (m : ∞ (IO B)) (f : (x : B) → ∞ (IO A)) → IO A
  _>>_   : {B : Set a} (m₁ : ∞ (IO B)) (m₂ : ∞ (IO A)) → IO A

{-# NON_TERMINATING #-}

run : ∀ {a} {A : Set a} → IO A → Prim.IO A
run (lift m)   = m
run (return x) = Prim.return x
run (m  >>= f) = Prim._>>=_ (run (♭ m )) λ x → run (♭ (f x))
run (m₁ >> m₂) = Prim._>>=_ (run (♭ m₁)) λ _ → run (♭ m₂)

putStr∞ : Costring → IO ⊤
putStr∞ s =
  ♯ lift (Prim.putStr s) >>
  ♯ return _

putStr : String → IO ⊤
putStr s = putStr∞ (toCostring s)

putStrLn∞ : Costring → IO ⊤
putStrLn∞ s =
  ♯ lift (Prim.putStrLn s) >>
  ♯ return _

putStrLn : String → IO ⊤
putStrLn s = putStrLn∞ (toCostring s)

_∨_ : Bool → Bool → Bool
Bool.true ∨ _  = Bool.true
Bool.false ∨ b = b

_∧_ : Bool → Bool → Bool
Bool.false ∧ _ = Bool.false
Bool.true ∧ b  = b

if_then_else_ : {A : Set} → Bool → A → A → A
if Bool.true  then a else _ = a
if Bool.false then _ else b = b

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

_>>>_ : String → String → String
_>>>_ = primStringAppend

infixl 1 _>>>_

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

data Principle : Set where
  # : String → Principle

_=p=_ : Principle → Principle → Bool
(# a) =p= (# b) = a == b

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

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A
infixr 5 _∷_

[[_]] : {A : Set} → A → List A
[[ x ]] = x ∷ []

any : {A : Set} → (A → Bool) → List A → Bool
any _ []       = Bool.false
any f (x ∷ xs) = (f x) ∨ (any f xs)

_∈∈_ : Principle → List Principle → Bool
x ∈∈ []       = Bool.false
x ∈∈ (y ∷ ys) with x =p= y
...             | Bool.true  = Bool.true
...             | Bool.false = x ∈∈ ys

_∋∋_ : List Principle → Principle → Bool
xs ∋∋ y = y ∈∈ xs

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

data Arrow : Set where
  ⇒_  : Principle → Arrow
  _⇒_ : Principle → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q =p= s
(p ⇒ q) ≡≡ (r ⇒ s) = (p =p= r) ∧ (q ≡≡ s)
_ ≡≡ _             = Bool.false

_∈∈∈∈_ : Arrow → List Arrow → Bool
x ∈∈∈∈ []       = Bool.false
x ∈∈∈∈ (y ∷ ys) with x ≡≡ y
...              | Bool.true  = Bool.true
...              | Bool.false = x ∈∈∈∈ ys

closure : List Arrow → List Principle → List Principle
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈∈ found) ∨ (n ∈∈ (closure rest found))
...                               | Bool.true  = closure (q ∷ rest) found
...                               | Bool.false = closure rest found

_,_⊢_ : List Arrow → List Principle → Principle → Bool
cs , ps ⊢ q = q ∈∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List Principle → List Principle → Separation

modelsupports : Separation → List Arrow → Principle → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → Principle → Bool
modeldenies (model _ fails) cs n = any (_∋∋_ (closure cs ([[ n ]]))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr     = Bool.false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈∈∈ cs)
...                   | Bool.true  = Proved
...                   | Bool.false with (cs ⊢ arr)
...                              | Bool.true  = Derivable
...                              | Bool.false with (cs ⟪ ms ⟫ arr)
...                                         | Bool.true  = Separated
...                                         | Bool.false = Unknown

proofs : List Arrow
proofs =
   ((# "3") ⇒ (⇒ (# "4"))) ∷
--   ((# "5") ⇒ (⇒ (# "4"))) ∷
   ((# "6") ⇒ (⇒ (# "4"))) ∷
   ((# "3") ⇒ (⇒ (# "3"))) ∷
   ((# "3") ⇒ (⇒ (# "3"))) ∷
   ((# "9") ⇒ (⇒ (# "3"))) ∷
   ((# "9") ⇒ (⇒ (# "3"))) ∷
   ((# "5") ⇒ (⇒ (# "7"))) ∷
   ((# "9") ⇒ (⇒ (# "7"))) ∷
   ((# "6") ⇒ (⇒ (# "8"))) ∷
   ((# "10") ⇒ (⇒ (# "8"))) ∷
   ((# "10") ⇒ (⇒ (# "7"))) ∷
   ((# "5") ⇒ (⇒ (# "10"))) ∷
   ((# "10") ⇒ (⇒ (# "4"))) ∷
   ((# "5") ⇒ (⇒ (# "11"))) ∷
   ((# "6") ⇒ (⇒ (# "11"))) ∷
   ((# "11") ⇒ (⇒ (# "4"))) ∷
   ((# "10") ⇒ (⇒ (# "7"))) ∷
   ((# "8") ⇒ (⇒ (# "4"))) ∷
   ((# "9") ⇒ (⇒ (# "7"))) ∷
   ((# "9") ⇒ (⇒ (# "8"))) ∷
   ((# "3") ⇒ (⇒ (# "8"))) ∷
   ((# "5") ⇒ ((# "3") ⇒ (⇒ (# "9")))) ∷
   ((# "6") ⇒ ((# "7") ⇒ (⇒ (# "10")))) ∷
   ((# "6") ⇒ ((# "3") ⇒ (⇒ (# "3")))) ∷
   ((# "7") ⇒ (⇒ (# "7"))) ∷
   ((# "7") ⇒ (⇒ (# "7"))) ∷
   ((# "7") ⇒ ((# "8") ⇒ (⇒ (# "10")))) ∷
   ((# "3") ⇒ ((# "10") ⇒ (⇒ (# "9")))) ∷
   ((# "5") ⇒ (⇒ (# "1"))) ∷
   ((# "3") ⇒ ((# "1") ⇒ (⇒ (# "9")))) ∷
   ((# "1") ⇒ (⇒ (# "2"))) ∷
   ((# "10") ⇒ (⇒ (# "2"))) ∷ []

cms : List Separation
cms =
  (model ((# "12") ∷ (# "6") ∷ (# "11") ∷ (# "4") ∷ (# "1") ∷ []) ((# "5") ∷ (# "3") ∷ (# "7") ∷ (# "7") ∷ [])) ∷
  (model ((# "6") ∷ (# "3") ∷ (# "11") ∷ (# "4") ∷ (# "7") ∷ (# "8") ∷ (# "3") ∷ (# "9") ∷ (# "10") ∷ (# "1") ∷ []) ((# "5") ∷ [])) ∷
  (model ((# "12") ∷ (# "5") ∷ (# "11") ∷ (# "4") ∷ (# "1") ∷ []) ((# "6") ∷ (# "3") ∷ [])) ∷
  (model ((# "5") ∷ (# "3") ∷ (# "11") ∷ (# "4") ∷ (# "7") ∷ (# "8") ∷ (# "3") ∷ (# "9") ∷ (# "10") ∷ (# "1") ∷ []) ((# "6") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "11") ∷ []) ((# "5") ∷ (# "6") ∷ (# "3") ∷ (# "8") ∷ (# "9") ∷ (# "1") ∷ [])) ∷
  (model ((# "12") ∷ (# "5") ∷ (# "6") ∷ (# "4") ∷ (# "11") ∷ (# "1") ∷ []) ((# "3") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "11") ∷ (# "7") ∷ []) ((# "9") ∷ (# "5") ∷ (# "6") ∷ (# "10") ∷ (# "8") ∷ (# "1") ∷ [])) ∷
  (model ((# "10") ∷ (# "9") ∷ []) ((# "1") ∷ [])) ∷
  (model ((# "3") ∷ (# "4") ∷ (# "11") ∷ []) ((# "9") ∷ (# "5") ∷ (# "6") ∷ (# "10") ∷ (# "7") ∷ (# "1") ∷ [])) ∷
  (model ((# "12") ∷ (# "7") ∷ (# "1") ∷ []) ((# "4") ∷ (# "11") ∷ (# "8") ∷ [])) ∷
  (model ((# "9") ∷ (# "3") ∷ (# "10") ∷ (# "8") ∷ (# "1") ∷ []) ((# "11") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "10") ∷ (# "1") ∷ []) ((# "11") ∷ (# "3") ∷ [])) ∷
  (model ((# "3") ∷ (# "6") ∷ (# "5") ∷ []) ([])) ∷
  (model ((# "1") ∷ (# "2") ∷ (# "3") ∷ (# "4") ∷ (# "5") ∷ (# "6") ∷ (# "7") ∷ (# "8") ∷ (# "9") ∷ (# "10") ∷ (# "11") ∷ []) ((# "12") ∷ [])) ∷ []

testp : Relation
testp = consider proofs cms ((# "5") ⇒ (⇒ (# "10")))

testd : Relation
testd = consider proofs cms ((# "5") ⇒ (⇒ (# "4")))

tests : Relation
tests = consider proofs cms ((# "5") ⇒ (⇒ (# "3")))

testu : Relation
testu = consider proofs cms ((# "6") ⇒ (⇒ (# "1")))

testcl : List Principle
testcl = closure proofs ((# "5") ∷ [])

stringifylp : List Principle → String
stringifylp [] = "[]"
stringifylp ((# s) ∷ xs) = s >>> " ∷ " >>> (stringifylp xs)

main = run (putStrLn (stringifylp testcl))

open import IO

data Bool : Set where
  true  : Bool
  false : Bool
-- {-# BUILTIN BOOL  Bool  #-}
-- {-# BUILTIN TRUE  true  #-}
-- {-# BUILTIN FALSE false #-}

_∨_ : Bool → Bool → Bool
true ∨ _  = true
false ∨ b = b

_∧_ : Bool → Bool → Bool
false ∧ _ = false
true ∧ b  = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then a else _ = a
if false then _ else b = b

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

postulate String : Set
{-# BUILTIN STRING String #-}

primitive
  primStringAppend   : String → String → String
  primStringEquality : String → String → Bool
  primShowString     : String → String

_>>>_ : String → String → String
_>>>_ = primStringAppend

_===_ : String → String → Bool
_===_ = primStringEquality

infixl 1 _>>>_

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

data Principle : Set where
  # : String → Principle

_==_ : Principle → Principle → Bool
(# a) == (# b) = a === b

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

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A
infixr 5 _∷_

[_] : {A : Set} → A → List A
[ x ] = x ∷ []

any : {A : Set} → (A → Bool) → List A → Bool
any _ []       = false
any f (x ∷ xs) = (f x) ∨ (any f xs)

_∈_ : Principle → List Principle → Bool
x ∈ []       = false
x ∈ (y ∷ ys) with x == y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List Principle → Principle → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : Principle → Arrow
  _⇒_ : Principle → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q == s
(p ⇒ q) ≡≡ (r ⇒ s) = (p == r) ∧ (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []       = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List Principle → List Principle
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) ∨ (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List Principle → Principle → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List Principle → List Principle → Separation

modelsupports : Separation → List Arrow → Principle → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → Principle → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs ([ n ]))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr     = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   ((# "3") ⇒ (⇒ (# "4"))) ∷
--   ((# "5") ⇒ (⇒ (# "4"))) ∷
   ((# "6") ⇒ (⇒ (# "4"))) ∷
   ((# "3") ⇒ (⇒ (# "3"))) ∷
   ((# "3") ⇒ (⇒ (# "3"))) ∷
   ((# "9") ⇒ (⇒ (# "3"))) ∷
   ((# "9") ⇒ (⇒ (# "3"))) ∷
   ((# "5") ⇒ (⇒ (# "7"))) ∷
   ((# "9") ⇒ (⇒ (# "7"))) ∷
   ((# "6") ⇒ (⇒ (# "8"))) ∷
   ((# "10") ⇒ (⇒ (# "8"))) ∷
   ((# "10") ⇒ (⇒ (# "7"))) ∷
   ((# "5") ⇒ (⇒ (# "10"))) ∷
   ((# "10") ⇒ (⇒ (# "4"))) ∷
   ((# "5") ⇒ (⇒ (# "11"))) ∷
   ((# "6") ⇒ (⇒ (# "11"))) ∷
   ((# "11") ⇒ (⇒ (# "4"))) ∷
   ((# "10") ⇒ (⇒ (# "7"))) ∷
   ((# "8") ⇒ (⇒ (# "4"))) ∷
   ((# "9") ⇒ (⇒ (# "7"))) ∷
   ((# "9") ⇒ (⇒ (# "8"))) ∷
   ((# "3") ⇒ (⇒ (# "8"))) ∷
   ((# "5") ⇒ ((# "3") ⇒ (⇒ (# "9")))) ∷
   ((# "6") ⇒ ((# "7") ⇒ (⇒ (# "10")))) ∷
   ((# "6") ⇒ ((# "3") ⇒ (⇒ (# "3")))) ∷
   ((# "7") ⇒ (⇒ (# "7"))) ∷
   ((# "7") ⇒ (⇒ (# "7"))) ∷
   ((# "7") ⇒ ((# "8") ⇒ (⇒ (# "10")))) ∷
   ((# "3") ⇒ ((# "10") ⇒ (⇒ (# "9")))) ∷
   ((# "5") ⇒ (⇒ (# "1"))) ∷
   ((# "3") ⇒ ((# "1") ⇒ (⇒ (# "9")))) ∷
   ((# "1") ⇒ (⇒ (# "2"))) ∷
   ((# "10") ⇒ (⇒ (# "2"))) ∷ []

cms : List Separation
cms =
  (model ((# "12") ∷ (# "6") ∷ (# "11") ∷ (# "4") ∷ (# "1") ∷ []) ((# "5") ∷ (# "3") ∷ (# "7") ∷ (# "7") ∷ [])) ∷
  (model ((# "6") ∷ (# "3") ∷ (# "11") ∷ (# "4") ∷ (# "7") ∷ (# "8") ∷ (# "3") ∷ (# "9") ∷ (# "10") ∷ (# "1") ∷ []) ((# "5") ∷ [])) ∷
  (model ((# "12") ∷ (# "5") ∷ (# "11") ∷ (# "4") ∷ (# "1") ∷ []) ((# "6") ∷ (# "3") ∷ [])) ∷
  (model ((# "5") ∷ (# "3") ∷ (# "11") ∷ (# "4") ∷ (# "7") ∷ (# "8") ∷ (# "3") ∷ (# "9") ∷ (# "10") ∷ (# "1") ∷ []) ((# "6") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "11") ∷ []) ((# "5") ∷ (# "6") ∷ (# "3") ∷ (# "8") ∷ (# "9") ∷ (# "1") ∷ [])) ∷
  (model ((# "12") ∷ (# "5") ∷ (# "6") ∷ (# "4") ∷ (# "11") ∷ (# "1") ∷ []) ((# "3") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "11") ∷ (# "7") ∷ []) ((# "9") ∷ (# "5") ∷ (# "6") ∷ (# "10") ∷ (# "8") ∷ (# "1") ∷ [])) ∷
  (model ((# "10") ∷ (# "9") ∷ []) ((# "1") ∷ [])) ∷
  (model ((# "3") ∷ (# "4") ∷ (# "11") ∷ []) ((# "9") ∷ (# "5") ∷ (# "6") ∷ (# "10") ∷ (# "7") ∷ (# "1") ∷ [])) ∷
  (model ((# "12") ∷ (# "7") ∷ (# "1") ∷ []) ((# "4") ∷ (# "11") ∷ (# "8") ∷ [])) ∷
  (model ((# "9") ∷ (# "3") ∷ (# "10") ∷ (# "8") ∷ (# "1") ∷ []) ((# "11") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "10") ∷ (# "1") ∷ []) ((# "11") ∷ (# "3") ∷ [])) ∷
  (model ((# "3") ∷ (# "6") ∷ (# "5") ∷ []) ([])) ∷
  (model ((# "1") ∷ (# "2") ∷ (# "3") ∷ (# "4") ∷ (# "5") ∷ (# "6") ∷ (# "7") ∷ (# "8") ∷ (# "9") ∷ (# "10") ∷ (# "11") ∷ []) ((# "12") ∷ [])) ∷ []

testp : Relation
testp = consider proofs cms ((# "5") ⇒ (⇒ (# "10")))

testd : Relation
testd = consider proofs cms ((# "5") ⇒ (⇒ (# "4")))

tests : Relation
tests = consider proofs cms ((# "5") ⇒ (⇒ (# "3")))

testu : Relation
testu = consider proofs cms ((# "6") ⇒ (⇒ (# "1")))

testcl : List Principle
testcl = closure proofs ((# "5") ∷ [])

stringifylp : List Principle → String
stringifylp [] = "[]"
stringifylp ((# s) ∷ xs) = s >>> " ∷ " >>> (stringifylp xs)

main = run (putStrLn (stringifylp testcl))


Desc model: followed by the generic proof that map (f . g) = map f . map g