module Chapter4.Derivable.Equality where

open import Function

open import Data.Unit
open import Data.Sum
open import Data.Product

open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Data.Bool
open import Data.Maybe

open import Chapter2.Desc
open import Chapter2.Desc.Fixpoint

open import Chapter4.Derivable

infix 12 _`+_

data EqDesc : Desc  Set₁ where
  `1 : EqDesc `1
  `var : EqDesc `var
  _`×_ : ∀{Dl Dr}  (l : EqDesc Dl)(r : EqDesc Dr)  EqDesc (Dl  Dr)
  _`+_ : ∀{Dl Dr}  (l : EqDesc Dl)(r : EqDesc Dr)  EqDesc (Dl `+ Dr)


equalityCompat : (D : Desc)  SemiDec (EqDesc D)
equalityCompat `1 = just `1
equalityCompat `var = just `var
equalityCompat (x  y) with equalityCompat x | equalityCompat y 
... | just ex | just ey = just (ex  ey)
... | just p | nothing = nothing 
... | nothing | t₂ = nothing 
equalityCompat (x `+ y) with equalityCompat x | equalityCompat y 
... | just ex | just ey = just (ex `+ ey)
... | just p | nothing = nothing 
... | nothing | t₂ = nothing 
equalityCompat ( S T) = nothing
equalityCompat ( S T) = nothing

private 
  out :  {D : Desc}  μ D   D  (μ D)
  out  xs  = xs


module H (D : Desc)(q : EqDesc D) where
  uninj₁ : ∀{A B : Set}{x y : A}  inj₁ {_}{_}{_}{B} x  inj₁ y  x  y
  uninj₁ refl = refl
  
  uninj₂ : ∀{A B : Set}{x y : B}  inj₂ {_}{_}{A} x  inj₂ y  x  y
  uninj₂ refl = refl

  help : (R : Desc)  EqDesc R  (x y :  R  (μ D))  Dec (x  y)
  help `1 `1 tt tt = yes refl
  help `var `var  xs   ys  with help D q xs ys
  help `var `var  .ys   ys  | yes refl = yes refl
  help `var `var  xs   ys  | no ¬p = no (¬p  cong out)
  help (R₁  R₂) (q₁  q₂) (x₁ , x₂) (y₁ , y₂) 
      with help R₁ q₁ x₁ y₁ | help R₂ q₂ x₂ y₂
  help (R₁  R₂) (q₁  q₂) (.y₁ , .y₂) (y₁ , y₂) | yes refl | yes refl = yes refl
  help (R₁  R₂) (q₁  q₂) (.y₁ , x₂) (y₁ , y₂) | yes refl | no ¬p = no (¬p  cong  {(x , y)  y}))
  help (R₁  R₂) (q₁  q₂) (x₁ , x₂) (y₁ , y₂) | no ¬p | t = no (¬p  cong  {(x , y)  x}))
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₁ x₁) (inj₁ x₂) 
     with help R₁ q₁ x₁ x₂ 
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₁ .x₂) (inj₁ x₂) | yes refl = yes refl
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₁ x) (inj₁ y) | no ¬p = no (¬p  uninj₁)
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₂ x) (inj₂ y) 
     with help R₂ q₂ x y
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₂ .y₁) (inj₂ y₁) | yes refl = yes refl
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₂ x) (inj₂ y) | no ¬p = no (¬p  uninj₂)
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₁ x₁) (inj₂ y₁) = no  ())
  help (R₁ `+ R₂) (q₁ `+ q₂) (inj₂ y₁) (inj₁ x₁) = no  ()) 
  help ( S T) () x₁ y₁
  help ( S T) () x₁ y₁
  

equalityDerive : {D : Desc}  EqDesc D  (x y : μ D)  Dec (x  y)
equalityDerive {D} q  x    y  with H.help D q D q x y
equalityDerive q  .y   y  | yes refl = yes refl
equalityDerive q  x   y  | no ¬p = no (¬p  cong out)


Equality : Derive  D  (x y : μ D)  Dec (x  y))
Equality = record { subUniverse = EqDesc
                  ; belongTo = equalityCompat
                  ; derive = equalityDerive }