Maybe

Maybe

module Data.Maybe.NP where

open import Type hiding (★)
open import Function
import Level as L
open L using (_⊔_; lift; Lift)
open import Data.Maybe public
open import Algebra
open import Algebra.Structures
open import Algebra.FunctionProperties
open import Category.Applicative
import      Category.Monad as Cat
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_;_≗_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Logical
open import Function using (_$_;flip;id)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; zero; suc; _+_)

Π? : ∀ {a b} (A : ★ a) (B : A → ★ b) → ★ _
Π? A B = (x : A) → Maybe (B x)

_→?_ : ∀ {a b} → ★ a → ★ b → ★ _
A →? B = A → Maybe B

module M? ℓ where
  open Cat.RawMonadPlus (monadPlus {ℓ}) public
  applicative = rawIApplicative

open M? public using (applicative)

infixl 4 _⊛?_

-- More universe-polymorphic than M?._⊛_
_⊛?_ : ∀ {a b}{A : ★ a}{B : ★ b} → Maybe (A → B) → Maybe A → Maybe B
just f  ⊛? just x = just (f x)
_       ⊛? _      = nothing

-- More universe-polymorphic than M?._<$>_
map? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
map? f = maybe (just ∘′ f) nothing

⟪_·_⟫? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
⟪ f · x ⟫? = map? f x

⟪_·_·_⟫? : ∀ {a b c}
             {A : ★ a} {B : ★ b} {C : ★ c} →
             (A → B → C) → Maybe A → Maybe B → Maybe C
⟪ f · x · y ⟫? = map? f x ⊛? y

⟪_·_·_·_⟫? : ∀ {a b c d}
               {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             → (A → B → C → D)
             → Maybe A → Maybe B → Maybe C → Maybe D
⟪ f · x · y · z ⟫? = map? f x ⊛? y ⊛? z

join? : ∀ {a} {A : ★ a} → Maybe (Maybe A) → Maybe A
join? = M?.join _

Maybe^ : ∀ {a} → ℕ → ★ a → ★ a
Maybe^ zero    = id
Maybe^ (suc n) = Maybe ∘ Maybe^ n

just^ : ∀ {a} {A : ★ a} n → A → Maybe^ n A
just^ zero x = x
just^ (suc n) x = just (just^ n x)

Maybe^-∘-+ : ∀ {a} m n (A : ★ a) → Maybe^ m (Maybe^ n A) ≡ Maybe^ (m + n) A
Maybe^-∘-+ zero    _ _ = ≡.refl
Maybe^-∘-+ (suc m) _ _ = ≡.cong Maybe (Maybe^-∘-+ m _ _)

just-injective : ∀ {a} {A : ★ a} {x y : A}
                 → Maybe.just x ≡ just y → x ≡ y
just-injective ≡.refl = ≡.refl

maybe-just-nothing : ∀ {a} {A : ★ a} → maybe {A = A} just nothing ≗ id
maybe-just-nothing (just _)  = ≡.refl
maybe-just-nothing nothing   = ≡.refl

_≡JAll_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAll y = All (λ y' → All (_≡_ y') y) x

_≡JAny_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAny y = Any (λ y' → Any (_≡_ y') y) x

≡JAll-refl : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡JAll x
≡JAll-refl {x = just x}  = just (just ≡.refl)
≡JAll-refl {x = nothing} = nothing

just? : ∀ {a} {A : ★ a} → Maybe A → ★₀
just? nothing  = ⊥
just? (just _) = ⊤

just?→IsJust : ∀ {a} {A : ★ a} {x : Maybe A} → just? x → IsJust x
just?→IsJust {x = just _}  p = just _
just?→IsJust {x = nothing} ()

Any→just? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → just? x
Any→just? (just _) = _

data ⟦Maybe⟧ {a b r} {A : ★ a} {B : ★ b} (_∼_ : A → B → ★ r) : Maybe A → Maybe B → ★ (a ⊔ b ⊔ r) where
  ⟦just⟧ : ∀ {x₁ x₂} → (xᵣ : x₁ ∼ x₂) → ⟦Maybe⟧ _∼_ (just x₁) (just x₂)
  ⟦nothing⟧ : ⟦Maybe⟧ _∼_ nothing nothing

⟦maybe⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦★⟧ a ⟩⟦→⟧ (∀⟨ Bᵣ ∶ ⟦★⟧ b ⟩⟦→⟧ ((Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Bᵣ ⟦→⟧ (⟦Maybe⟧ Aᵣ ⟦→⟧ Bᵣ)))))
                     (maybe {a} {b}) (maybe {a} {b})
⟦maybe⟧ _ _ justᵣ nothingᵣ (⟦just⟧ xᵣ) = justᵣ xᵣ
⟦maybe⟧ _ _ justᵣ nothingᵣ ⟦nothing⟧   = nothingᵣ

Any-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any (Any P) x → Any P (join? x)
Any-join? (just p) = p

All-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All (All P) x → All P (join? x)
All-join? (just p) = p
All-join? nothing  = nothing

Any-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P (join? x) → Any (Any P) x
Any-join?′ {x = just x}  p = just p
Any-join?′ {x = nothing} ()

All-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All P (join? x) → All (All P) x
All-join?′ {x = just x}  p       = just p
All-join?′ {x = nothing} nothing = nothing

Any→IsJust : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → IsJust x
Any→IsJust (just _) = just _

just≡→just? : ∀ {a} {A : ★ a} {x} {y : A} → x ≡ just y → just? x
just≡→just? ≡.refl = _

just?-join? : ∀ {a} {A : ★ a} {x : Maybe (Maybe A)} → just? (join? x) → just? x
just?-join? = Any→just? ∘ Any-join?′ ∘ just?→IsJust

Any-just?-join? : ∀ {A : ★₀} (x : Maybe (Maybe A)) → just? (join? x) → Any just? x
Any-just?-join? (just (just _)) _ = just _
Any-just?-join? (just nothing)  ()
Any-just?-join? nothing         ()

just?-map? : ∀ {a b} {A : ★ a} {B : ★ b} (f : A → B)
               (x : Maybe A) → just? (map? f x) → just? x
just?-map? f (just x) pf = _
just?-map? f nothing  ()

infix 4 _≗?_

_≗?_ : ∀ {a b} {A : ★ a} {B : ★ b} →
         (f g : A →? B) → ★ _
(f ≗? g) = ∀ x → f x ≡JAll g x

_∘?_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
       → B →? C → A →? B → A →? C
f ∘? g = join? ∘ map? f ∘ g

∘?-just : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → f ∘? just ≗? f
∘?-just f x = ≡JAll-refl

just-∘? : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → just ∘? f ≗? f
just-∘? f x with f x
just-∘? f x | just _  = just (just ≡.refl)
just-∘? f x | nothing = nothing

∘?-assoc : ∀ {a b c d} {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             (f : C →? D) (g : B →? C) (h : A →? B)
             → (f ∘? g) ∘? h ≗ f ∘? (g ∘? h)
∘?-assoc f g h x with h x
∘?-assoc f g h x | just _  = ≡.refl
∘?-assoc f g h x | nothing = ≡.refl

T[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T[_] {A = A} {B} f? = (x : A) → .{pf : just? (f? x)} → B

F[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T[ f? ]
F[ f? ] x {pf} with f? x
F[ f? ] x      | just r  = r
F[ f? ] x {()} | nothing

T'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T'[_] {A = A} {B} f? = (x : A) → IsJust (f? x) → B

F'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T'[ f? ]
F'[ f? ] x pf with f? x
F'[ f? ] x (just {y} _) | .(just y) = y

-- F[ f? ] ⟶ F'[ f? ]

module F[] where
    _[≗]_ : ∀ {a b} {A : ★ a} {B : ★ b}
              {f? g? : A →? B}
              (f : T[ f? ]) (g : T[ g? ]) → ★ _
    f [≗] g = ∀ x {pf1} {pf2} → f x {pf1} ≡ g x {pf2}

    [id] : ∀ {a} {A : ★ a} → T[ just {A = A} ]
    [id] = F[ just ]

    {- might actually be wrong
    []-just-≡ : ∀ {a b} {A : ★ a} {B : ★ b} {f? : A →? B} (f : T[ f? ]) {x} (pf : just? (f? x)) → just (f x {pf}) ≡ f? x
    []-just-≡ {f? = f?} f {x} pf = {!!}
    -}

    _[∘]_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
              {f? : B →? C} {g? : A →? B}
            → T[ f? ] → T[ g? ] → T[ f? ∘? g? ]
    _[∘]_ {f? = f?} {g?} f g x {pf} with g? x
    _[∘]_ f g x {pf} | just y  = f y {pf}
    _[∘]_ f g x {()} | nothing

    {-
    [id]-[∘] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (F[ just ] [∘] f) [≗] f
    [id]-[∘] {f? = f?} f x {pf1} {pf2} = just-injective {!(≡.sym (≡.trans ([]-just-≡ f pf2) ?))!}
    -}

    [∘]-[id] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (f [∘] [id]) [≗] f
    [∘]-[id] {f? = f?} f x {pf1} {pf2} = ≡.refl

_⟦→?⟧_ : ∀ {a b c d} → (⟦★⟧ {a} {b} c ⟦→⟧ ⟦★⟧ {a} {b} d ⟦→⟧ ⟦★⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

module ⟦Maybe⟧-Properties where

  refl : ∀ {a p} {A : ★ a} {_∼_ : A → A → ★ p} (refl-A : ∀ x → x ∼ x) (mx : Maybe A) → ⟦Maybe⟧ _∼_ mx mx
  refl refl-A (just x) = ⟦just⟧ (refl-A x)
  refl refl-A nothing  = ⟦nothing⟧

  sym : ∀ {a b r₁ r₂} {A : ★ a} {B : ★ b} {_∼₁_ : A → B → ★ r₁} {_∼₂_ : B → A → ★ r₂}
          (sym-AB : ∀ {x y} → x ∼₁ y → y ∼₂ x) {mx : Maybe A} {my : Maybe B}
        → ⟦Maybe⟧ _∼₁_ mx my → ⟦Maybe⟧ _∼₂_ my mx
  sym sym-A (⟦just⟧ x∼₁y) = ⟦just⟧ (sym-A x∼₁y)
  sym sym-A ⟦nothing⟧ = ⟦nothing⟧

  trans : ∀ {a b c r₁ r₂ r₃} {A : ★ a} {B : ★ b} {C : ★ c}
            {_⟦AB⟧_ : A → B → ★ r₁}
            {_⟦BC⟧_ : B → C → ★ r₂}
            {_⟦AC⟧_ : A → C → ★ r₃}
            (trans : ∀ {x y z} → x ⟦AB⟧ y → y ⟦BC⟧ z → x ⟦AC⟧ z)
            {mx : Maybe A} {my : Maybe B} {mz : Maybe C}
          → ⟦Maybe⟧ _⟦AB⟧_ mx my → ⟦Maybe⟧ _⟦BC⟧_ my mz
          → ⟦Maybe⟧ _⟦AC⟧_ mx mz
  trans trans' (⟦just⟧ x∼y) (⟦just⟧ y∼z) = ⟦just⟧ (trans' x∼y y∼z)
  trans trans' ⟦nothing⟧ ⟦nothing⟧ = ⟦nothing⟧

  subst-⟦AB⟧ : ∀ {a b p q r} {A : ★ a} {B : ★ b}
                 (P : Maybe A → ★ p)
                 (Q : Maybe B → ★ q)
                 (⟦AB⟧ : A → B → ★ r)
                 (subst-⟦AB⟧-just : ∀ {x y} → ⟦AB⟧ x y → P (just x) → Q (just y))
                 (Pnothing→Qnothing : P nothing → Q nothing)
                 {mx : Maybe A} {my : Maybe B}
               → (⟦Maybe⟧ ⟦AB⟧ mx my) → P mx → Q my
  subst-⟦AB⟧ _ _ _ subst-⟦AB⟧-just _ (⟦just⟧ x∼y) Pmx = subst-⟦AB⟧-just x∼y Pmx
  subst-⟦AB⟧ _ _ _ _               f ⟦nothing⟧    Pnothing = f Pnothing

  subst : ∀ {a p r} {A : ★ a}
            (P : Maybe A → ★ p)
            (Aᵣ : A → A → ★ r)
            (subst-Aᵣ : ∀ {x y} → Aᵣ x y → P (just x) → P (just y))
            {mx my}
          → (⟦Maybe⟧ Aᵣ mx my) → P mx → P my
  subst P Aᵣ subst-Aᵣ = subst-⟦AB⟧ P P Aᵣ subst-Aᵣ id

IsNothing'≡nothing : ∀ {a} {A : ★ a} {x : Maybe A} → IsNothing x → x ≡ nothing
IsNothing'≡nothing nothing = ≡.refl
IsNothing'≡nothing (just (lift ()))

≡nothing'IsNothing : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡ nothing → IsNothing x
≡nothing'IsNothing ≡.refl = nothing

module FunctorLemmas {a} where
  open M? a

  <$>-injective₁ : ∀ {A B}
                     {f : A → B} {x y : Maybe A}
                     (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y)
                   → f <$> x ≡ f <$> y → x ≡ y
  <$>-injective₁ {x = just _}  {just _}  f-inj eq = ≡.cong just (f-inj (just-injective eq))
  <$>-injective₁ {x = nothing} {nothing} _     _  = ≡.refl
  <$>-injective₁ {x = just _}  {nothing} _     ()
  <$>-injective₁ {x = nothing} {just _}  _     ()

  <$>-assoc : ∀ {A B C} {f : A → B} {g : C → A} (x : Maybe C) → f ∘ g <$> x ≡ f <$> (g <$> x)
  <$>-assoc (just _) = ≡.refl
  <$>-assoc nothing  = ≡.refl

module MonadLemmas {a} where

  open M? a public
 --  open RawApplicative applicative public

  cong-Maybe : ∀ {A B}
                 (f : A → B) {x y} → x ≡ pure y → f <$> x ≡ pure (f y)
  cong-Maybe f ≡.refl = ≡.refl

  cong₂-Maybe : ∀ {A B C}
                  (f : A → B → C) {x y u v} → x ≡ pure y → u ≡ pure v → pure f ⊛ x ⊛ u ≡ pure (f y v)
  cong₂-Maybe f ≡.refl ≡.refl = ≡.refl

  Maybe-comm-monad :
    ∀ {A B C} {x y} {f : A → B → Maybe C} →
      (x >>= λ x' → y >>= λ y' → f x' y')
    ≡ (y >>= λ y' → x >>= λ x' → f x' y')
  Maybe-comm-monad {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-monad {x = nothing} {just _}   = ≡.refl
  Maybe-comm-monad {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-monad {x = just _}  {just _}   = ≡.refl

  Maybe-comm-appl : ∀ {A B} {f : Maybe (A → B)} {x} → f ⊛ x ≡ (flip _$_) <$> x ⊛ f
  Maybe-comm-appl {f = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl {f = nothing} {just _}   = ≡.refl
  Maybe-comm-appl {f = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl {f = just _}  {just _}   = ≡.refl

  Maybe-comm-appl₂ : ∀ {A B C} {f : A → B → C} {x y} → f <$> x ⊛ y ≡ flip f <$> y ⊛ x
  Maybe-comm-appl₂ {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = nothing} {just _}   = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {just _}   = ≡.refl

module MonoidFromSemigroup {c ℓ} (sg   : Semigroup c ℓ)
                                 {_≈?_ : let open Semigroup sg
                                         in Maybe Carrier → Maybe Carrier → ★ ℓ}
                                 (isEquivalence : IsEquivalence _≈?_)
                                 (just-cong : let open Semigroup sg in
                                              just Preserves _≈_ ⟶ _≈?_)
                                 (just-inj  : let open Semigroup sg in
                                              (_≈?_ on just) ⇒ _≈_)
                                 (just≉nothing : ∀ {x} → ¬(just x ≈? nothing)) where
  private
    module SG = Semigroup sg
    open SG using (_≈_) renaming (Carrier to A; _∙_ to op)
    module ≈  = IsEquivalence SG.isEquivalence
    module ≈? = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    just x  ∙ just y  = just (op x y)
    just x  ∙ nothing = just x
    nothing ∙ y?      = y?

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈?_ _∙_
    assoc (just x) (just y) (just z) = just-cong (SG.assoc x y z)
    assoc (just _) (just _) nothing  = ≈?.refl
    assoc (just _) nothing  _        = ≈?.refl
    assoc nothing  _        _        = ≈?.refl

    right-identity : RightIdentity _≈?_ ε _∙_
    right-identity (just _) = ≈?.refl
    right-identity nothing  = ≈?.refl

    ∙-cong : _∙_ Preserves₂ _≈?_ ⟶ _≈?_ ⟶ _≈?_
    ∙-cong {just _}{just _}{just _}{just _}   p q
      = just-cong (SG.∙-cong (just-inj p) (just-inj q))
    ∙-cong {just _}{just _}{just _}{nothing}  p q = ⊥-elim (just≉nothing q)
    ∙-cong {just _}{just _}{nothing}{just _}  p q = ⊥-elim (just≉nothing (≈?.sym q))
    ∙-cong {just _}{just _}{nothing}{nothing} p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _}  {nothing} p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈?.sym p))

  monoid : Monoid c ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈?_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈?.refl) , right-identity } }

  open Monoid monoid public

module Monoid-≡ {a} {A : ★ a} {op : Op₂ A} (isSg : IsSemigroup _≡_ op)
  = MonoidFromSemigroup (record { isSemigroup = isSg })
                        ≡.isEquivalence (≡.cong just) just-injective

module First-≈ {a ℓ} {A : ★ a} {_≈_ : Maybe A → Maybe A → ★ ℓ}
               (isEquivalence : IsEquivalence _≈_)
               (just≉nothing : ∀ {x} → ¬(just x ≈ nothing)) where
  private
    module ≈ = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    x ∙ y = maybe just y x

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈_ _∙_
    assoc (just _) _ _ = ≈.refl
    assoc nothing  _ _ = ≈.refl

    right-identity : RightIdentity _≈_ ε _∙_
    right-identity (just _) = ≈.refl
    right-identity nothing  = ≈.refl

    ∙-cong : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
    ∙-cong {just _} {just _}   p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _} {nothing}  p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈.sym p))

  monoid : Monoid a ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈.refl) , right-identity } }

  open Monoid monoid public

module First {a} (A : ★ a) = First-≈ {A = A} ≡.isEquivalence (λ())

module Data.Maybe.NP where

open import Type hiding (★)
open import Function
import Level as L
open L using (_⊔_; lift; Lift)
open import Data.Maybe public
open import Algebra
open import Algebra.Structures
open import Algebra.FunctionProperties
open import Category.Applicative
import      Category.Monad as Cat
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_;_≗_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Logical
open import Function using (type-signature;_$_;flip;id)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; zero; suc; _+_)

Π? : ∀ {a b} (A : ★ a) (B : A → ★ b) → ★ _
Π? A B = (x : A) → Maybe (B x)

_→?_ : ∀ {a b} → ★ a → ★ b → ★ _
A →? B = A → Maybe B

module M? ℓ where
  open Cat.RawMonadPlus (monadPlus {ℓ}) public
  applicative = rawIApplicative

open M? public using (applicative)

infixl 4 _⊛?_

-- More universe-polymorphic than M?._⊛_
_⊛?_ : ∀ {a b}{A : ★ a}{B : ★ b} → Maybe (A → B) → Maybe A → Maybe B
just f  ⊛? just x = just (f x)
_       ⊛? _      = nothing

-- More universe-polymorphic than M?._<$>_
map? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
map? f = maybe (just ∘′ f) nothing

⟪_·_⟫? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
⟪ f · x ⟫? = map? f x

⟪_·_·_⟫? : ∀ {a b c}
             {A : ★ a} {B : ★ b} {C : ★ c} →
             (A → B → C) → Maybe A → Maybe B → Maybe C
⟪ f · x · y ⟫? = map? f x ⊛? y

⟪_·_·_·_⟫? : ∀ {a b c d}
               {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             → (A → B → C → D)
             → Maybe A → Maybe B → Maybe C → Maybe D
⟪ f · x · y · z ⟫? = map? f x ⊛? y ⊛? z

join? : ∀ {a} {A : ★ a} → Maybe (Maybe A) → Maybe A
join? = M?.join _

Maybe^ : ∀ {a} → ℕ → ★ a → ★ a
Maybe^ zero    = id
Maybe^ (suc n) = Maybe ∘ Maybe^ n

just^ : ∀ {a} {A : ★ a} n → A → Maybe^ n A
just^ zero x = x
just^ (suc n) x = just (just^ n x)

Maybe^-∘-+ : ∀ {a} m n (A : ★ a) → Maybe^ m (Maybe^ n A) ≡ Maybe^ (m + n) A
Maybe^-∘-+ zero    _ _ = ≡.refl
Maybe^-∘-+ (suc m) _ _ = ≡.cong Maybe (Maybe^-∘-+ m _ _)

just-injective : ∀ {a} {A : ★ a} {x y : A}
                 → Maybe.just x ≡ just y → x ≡ y
just-injective ≡.refl = ≡.refl

maybe-just-nothing : ∀ {a} {A : ★ a} → maybe {A = A} just nothing ≗ id
maybe-just-nothing (just _)  = ≡.refl
maybe-just-nothing nothing   = ≡.refl

_≡JAll_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAll y = All (λ y' → All (_≡_ y') y) x

_≡JAny_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAny y = Any (λ y' → Any (_≡_ y') y) x

≡JAll-refl : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡JAll x
≡JAll-refl {x = just x}  = just (just ≡.refl)
≡JAll-refl {x = nothing} = nothing

just? : ∀ {a} {A : ★ a} → Maybe A → ★₀
just? nothing  = ⊥
just? (just _) = ⊤

just?→IsJust : ∀ {a} {A : ★ a} {x : Maybe A} → just? x → IsJust x
just?→IsJust {x = just _}  p = just _
just?→IsJust {x = nothing} ()

Any→just? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → just? x
Any→just? (just _) = _

data ⟦Maybe⟧ {a b r} {A : ★ a} {B : ★ b} (_∼_ : A → B → ★ r) : Maybe A → Maybe B → ★ (a ⊔ b ⊔ r) where
  ⟦just⟧ : ∀ {x₁ x₂} → (xᵣ : x₁ ∼ x₂) → ⟦Maybe⟧ _∼_ (just x₁) (just x₂)
  ⟦nothing⟧ : ⟦Maybe⟧ _∼_ nothing nothing

⟦maybe⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦★⟧ a ⟩⟦→⟧ (∀⟨ Bᵣ ∶ ⟦★⟧ b ⟩⟦→⟧ ((Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Bᵣ ⟦→⟧ (⟦Maybe⟧ Aᵣ ⟦→⟧ Bᵣ)))))
                     (maybe {a} {b}) (maybe {a} {b})
⟦maybe⟧ _ _ justᵣ nothingᵣ (⟦just⟧ xᵣ) = justᵣ xᵣ
⟦maybe⟧ _ _ justᵣ nothingᵣ ⟦nothing⟧   = nothingᵣ

Any-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any (Any P) x → Any P (join? x)
Any-join? (just p) = p

All-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All (All P) x → All P (join? x)
All-join? (just p) = p
All-join? nothing  = nothing

Any-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P (join? x) → Any (Any P) x
Any-join?′ {x = just x}  p = just p
Any-join?′ {x = nothing} ()

All-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All P (join? x) → All (All P) x
All-join?′ {x = just x}  p       = just p
All-join?′ {x = nothing} nothing = nothing

Any→IsJust : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → IsJust x
Any→IsJust (just _) = just _

just≡→just? : ∀ {a} {A : ★ a} {x} {y : A} → x ≡ just y → just? x
just≡→just? ≡.refl = _

just?-join? : ∀ {a} {A : ★ a} {x : Maybe (Maybe A)} → just? (join? x) → just? x
just?-join? = Any→just? ∘ Any-join?′ ∘ just?→IsJust

Any-just?-join? : ∀ {A : ★₀} (x : Maybe (Maybe A)) → just? (join? x) → Any just? x
Any-just?-join? (just (just _)) _ = just _
Any-just?-join? (just nothing)  ()
Any-just?-join? nothing         ()

just?-map? : ∀ {a b} {A : ★ a} {B : ★ b} (f : A → B)
               (x : Maybe A) → just? (map? f x) → just? x
just?-map? f (just x) pf = _
just?-map? f nothing  ()

infix 4 _≗?_

_≗?_ : ∀ {a b} {A : ★ a} {B : ★ b} →
         (f g : A →? B) → ★ _
(f ≗? g) = ∀ x → f x ≡JAll g x

_∘?_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
       → B →? C → A →? B → A →? C
f ∘? g = join? ∘ map? f ∘ g

∘?-just : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → f ∘? just ≗? f
∘?-just f x = ≡JAll-refl

just-∘? : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → just ∘? f ≗? f
just-∘? f x with f x
just-∘? f x | just _  = just (just ≡.refl)
just-∘? f x | nothing = nothing

∘?-assoc : ∀ {a b c d} {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             (f : C →? D) (g : B →? C) (h : A →? B)
             → (f ∘? g) ∘? h ≗ f ∘? (g ∘? h)
∘?-assoc f g h x with h x
∘?-assoc f g h x | just _  = ≡.refl
∘?-assoc f g h x | nothing = ≡.refl

T[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T[_] {A = A} {B} f? = (x : A) → .{pf : just? (f? x)} → B

F[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T[ f? ]
F[ f? ] x {pf} with f? x
F[ f? ] x      | just r  = r
F[ f? ] x {()} | nothing

T'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T'[_] {A = A} {B} f? = (x : A) → IsJust (f? x) → B

F'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T'[ f? ]
F'[ f? ] x pf with f? x
F'[ f? ] x (just {y} _) | .(just y) = y

-- F[ f? ] ⟶ F'[ f? ]

module F[] where
    _[≗]_ : ∀ {a b} {A : ★ a} {B : ★ b}
              {f? g? : A →? B}
              (f : T[ f? ]) (g : T[ g? ]) → ★ _
    f [≗] g = ∀ x {pf1} {pf2} → f x {pf1} ≡ g x {pf2}

    [id] : ∀ {a} {A : ★ a} → T[ just {A = A} ]
    [id] = F[ just ]

    {- might actually be wrong
    []-just-≡ : ∀ {a b} {A : ★ a} {B : ★ b} {f? : A →? B} (f : T[ f? ]) {x} (pf : just? (f? x)) → just (f x {pf}) ≡ f? x
    []-just-≡ {f? = f?} f {x} pf = {!!}
    -}

    _[∘]_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
              {f? : B →? C} {g? : A →? B}
            → T[ f? ] → T[ g? ] → T[ f? ∘? g? ]
    _[∘]_ {f? = f?} {g?} f g x {pf} with g? x
    _[∘]_ f g x {pf} | just y  = f y {pf}
    _[∘]_ f g x {()} | nothing

    {-
    [id]-[∘] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (F[ just ] [∘] f) [≗] f
    [id]-[∘] {f? = f?} f x {pf1} {pf2} = just-injective {!(≡.sym (≡.trans ([]-just-≡ f pf2) ?))!}
    -}

    [∘]-[id] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (f [∘] [id]) [≗] f
    [∘]-[id] {f? = f?} f x {pf1} {pf2} = ≡.refl

_⟦→?⟧_ : ∀ {a b c d} → (⟦★⟧ {a} {b} c ⟦→⟧ ⟦★⟧ {a} {b} d ⟦→⟧ ⟦★⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

module ⟦Maybe⟧-Properties where

  refl : ∀ {a p} {A : ★ a} {_∼_ : A → A → ★ p} (refl-A : ∀ x → x ∼ x) (mx : Maybe A) → ⟦Maybe⟧ _∼_ mx mx
  refl refl-A (just x) = ⟦just⟧ (refl-A x)
  refl refl-A nothing  = ⟦nothing⟧

  sym : ∀ {a b r₁ r₂} {A : ★ a} {B : ★ b} {_∼₁_ : A → B → ★ r₁} {_∼₂_ : B → A → ★ r₂}
          (sym-AB : ∀ {x y} → x ∼₁ y → y ∼₂ x) {mx : Maybe A} {my : Maybe B}
        → ⟦Maybe⟧ _∼₁_ mx my → ⟦Maybe⟧ _∼₂_ my mx
  sym sym-A (⟦just⟧ x∼₁y) = ⟦just⟧ (sym-A x∼₁y)
  sym sym-A ⟦nothing⟧ = ⟦nothing⟧

  trans : ∀ {a b c r₁ r₂ r₃} {A : ★ a} {B : ★ b} {C : ★ c}
            {_⟦AB⟧_ : A → B → ★ r₁}
            {_⟦BC⟧_ : B → C → ★ r₂}
            {_⟦AC⟧_ : A → C → ★ r₃}
            (trans : ∀ {x y z} → x ⟦AB⟧ y → y ⟦BC⟧ z → x ⟦AC⟧ z)
            {mx : Maybe A} {my : Maybe B} {mz : Maybe C}
          → ⟦Maybe⟧ _⟦AB⟧_ mx my → ⟦Maybe⟧ _⟦BC⟧_ my mz
          → ⟦Maybe⟧ _⟦AC⟧_ mx mz
  trans trans' (⟦just⟧ x∼y) (⟦just⟧ y∼z) = ⟦just⟧ (trans' x∼y y∼z)
  trans trans' ⟦nothing⟧ ⟦nothing⟧ = ⟦nothing⟧

  subst-⟦AB⟧ : ∀ {a b p q r} {A : ★ a} {B : ★ b}
                 (P : Maybe A → ★ p)
                 (Q : Maybe B → ★ q)
                 (⟦AB⟧ : A → B → ★ r)
                 (subst-⟦AB⟧-just : ∀ {x y} → ⟦AB⟧ x y → P (just x) → Q (just y))
                 (Pnothing→Qnothing : P nothing → Q nothing)
                 {mx : Maybe A} {my : Maybe B}
               → (⟦Maybe⟧ ⟦AB⟧ mx my) → P mx → Q my
  subst-⟦AB⟧ _ _ _ subst-⟦AB⟧-just _ (⟦just⟧ x∼y) Pmx = subst-⟦AB⟧-just x∼y Pmx
  subst-⟦AB⟧ _ _ _ _               f ⟦nothing⟧    Pnothing = f Pnothing

  subst : ∀ {a p r} {A : ★ a}
            (P : Maybe A → ★ p)
            (Aᵣ : A → A → ★ r)
            (subst-Aᵣ : ∀ {x y} → Aᵣ x y → P (just x) → P (just y))
            {mx my}
          → (⟦Maybe⟧ Aᵣ mx my) → P mx → P my
  subst P Aᵣ subst-Aᵣ = subst-⟦AB⟧ P P Aᵣ subst-Aᵣ id

IsNothing'≡nothing : ∀ {a} {A : ★ a} {x : Maybe A} → IsNothing x → x ≡ nothing
IsNothing'≡nothing nothing = ≡.refl
IsNothing'≡nothing (just (lift ()))

≡nothing'IsNothing : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡ nothing → IsNothing x
≡nothing'IsNothing ≡.refl = nothing

module FunctorLemmas {a} where
  open M? a

  <$>-injective₁ : ∀ {A B}
                     {f : A → B} {x y : Maybe A}
                     (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y)
                   → f <$> x ≡ f <$> y → x ≡ y
  <$>-injective₁ {x = just _}  {just _}  f-inj eq = ≡.cong just (f-inj (just-injective eq))
  <$>-injective₁ {x = nothing} {nothing} _     _  = ≡.refl
  <$>-injective₁ {x = just _}  {nothing} _     ()
  <$>-injective₁ {x = nothing} {just _}  _     ()

  <$>-assoc : ∀ {A B C} {f : A → B} {g : C → A} (x : Maybe C) → f ∘ g <$> x ≡ f <$> (g <$> x)
  <$>-assoc (just _) = ≡.refl
  <$>-assoc nothing  = ≡.refl

module MonadLemmas {a} where

  open M? a public
 --  open RawApplicative applicative public

  cong-Maybe : ∀ {A B}
                 (f : A → B) {x y} → x ≡ pure y → f <$> x ≡ pure (f y)
  cong-Maybe f ≡.refl = ≡.refl

  cong₂-Maybe : ∀ {A B C}
                  (f : A → B → C) {x y u v} → x ≡ pure y → u ≡ pure v → pure f ⊛ x ⊛ u ≡ pure (f y v)
  cong₂-Maybe f ≡.refl ≡.refl = ≡.refl

  Maybe-comm-monad :
    ∀ {A B C} {x y} {f : A → B → Maybe C} →
      (x >>= λ x' → y >>= λ y' → f x' y')
    ≡ (y >>= λ y' → x >>= λ x' → f x' y')
  Maybe-comm-monad {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-monad {x = nothing} {just _}   = ≡.refl
  Maybe-comm-monad {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-monad {x = just _}  {just _}   = ≡.refl

  Maybe-comm-appl : ∀ {A B} {f : Maybe (A → B)} {x} → f ⊛ x ≡ (flip _$_) <$> x ⊛ f
  Maybe-comm-appl {f = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl {f = nothing} {just _}   = ≡.refl
  Maybe-comm-appl {f = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl {f = just _}  {just _}   = ≡.refl

  Maybe-comm-appl₂ : ∀ {A B C} {f : A → B → C} {x y} → f <$> x ⊛ y ≡ flip f <$> y ⊛ x
  Maybe-comm-appl₂ {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = nothing} {just _}   = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {just _}   = ≡.refl

module MonoidFromSemigroup {c ℓ} (sg   : Semigroup c ℓ)
                                 {_≈?_ : let open Semigroup sg
                                         in Maybe Carrier → Maybe Carrier → ★ ℓ}
                                 (isEquivalence : IsEquivalence _≈?_)
                                 (just-cong : let open Semigroup sg in
                                              just Preserves _≈_ ⟶ _≈?_)
                                 (just-inj  : let open Semigroup sg in
                                              (_≈?_ on just) ⇒ _≈_)
                                 (just≉nothing : ∀ {x} → ¬(just x ≈? nothing)) where
  private
    module SG = Semigroup sg
    open SG using (_≈_) renaming (Carrier to A; _∙_ to op)
    module ≈  = IsEquivalence SG.isEquivalence
    module ≈? = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    just x  ∙ just y  = just (op x y)
    just x  ∙ nothing = just x
    nothing ∙ y?      = y?

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈?_ _∙_
    assoc (just x) (just y) (just z) = just-cong (SG.assoc x y z)
    assoc (just _) (just _) nothing  = ≈?.refl
    assoc (just _) nothing  _        = ≈?.refl
    assoc nothing  _        _        = ≈?.refl

    right-identity : RightIdentity _≈?_ ε _∙_
    right-identity (just _) = ≈?.refl
    right-identity nothing  = ≈?.refl

    ∙-cong : _∙_ Preserves₂ _≈?_ ⟶ _≈?_ ⟶ _≈?_
    ∙-cong {just _}{just _}{just _}{just _}   p q
      = just-cong (SG.∙-cong (just-inj p) (just-inj q))
    ∙-cong {just _}{just _}{just _}{nothing}  p q = ⊥-elim (just≉nothing q)
    ∙-cong {just _}{just _}{nothing}{just _}  p q = ⊥-elim (just≉nothing (≈?.sym q))
    ∙-cong {just _}{just _}{nothing}{nothing} p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _}  {nothing} p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈?.sym p))

  monoid : Monoid c ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈?_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈?.refl) , right-identity } }

  open Monoid monoid public

module Monoid-≡ {a} {A : ★ a} {op : Op₂ A} (isSg : IsSemigroup _≡_ op)
  = MonoidFromSemigroup (record { isSemigroup = isSg })
                        ≡.isEquivalence (≡.cong just) just-injective

module First-≈ {a ℓ} {A : ★ a} {_≈_ : Maybe A → Maybe A → ★ ℓ}
               (isEquivalence : IsEquivalence _≈_)
               (just≉nothing : ∀ {x} → ¬(just x ≈ nothing)) where
  private
    module ≈ = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    x ∙ y = maybe just y x

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈_ _∙_
    assoc (just _) _ _ = ≈.refl
    assoc nothing  _ _ = ≈.refl

    right-identity : RightIdentity _≈_ ε _∙_
    right-identity (just _) = ≈.refl
    right-identity nothing  = ≈.refl

    ∙-cong : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
    ∙-cong {just _} {just _}   p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _} {nothing}  p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈.sym p))

  monoid : Monoid a ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈.refl) , right-identity } }

  open Monoid monoid public

module First {a} (A : ★ a) = First-≈ {A = A} ≡.isEquivalence (λ())


commenting out some cases that no longer work with more precise indeterminate forms -- this reveals some stepping rules that are missing

open import Nat
open import Prelude
open import List
open import core
open import contexts

module progress where

  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → Δ ⊢ d err → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d Δ
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | _
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp (TALam D1) MAArr D2) | V VLam | I x₁ = S (_ , Step (FAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!})
  progress (TAAp D1 x₂ D2) | _ | E x₁ = E (EAp2 x₁)
  progress (TAAp D1 x₂ D2) | E x | _ = E (EAp1 x)
  -- progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I IEHole | V x₁ = I (IAp IEHole (FVal x₁))
  progress (TAAp D1 x₂ D2) | I (INEHole x) | V x₁ = I (IAp (INEHole x) (FVal x₁))
  progress (TAAp D1 x₃ D2) | I (IAp x x₁) | V x₂ = I (IAp (IAp x x₁) (FVal x₂))
  progress (TAAp D1 x₂ D2) | I (ICast x) | V x₁ = I (IAp (ICast x) (FVal x₁))
  progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
  progress (TAAp {d1 = d1} D1 x₄ D2) | _ | S (d , Step x₁ x₂ x₃) = S ((d1 ∘ d) , (Step {!!} (ITLam (FIndet {!!})) {!!}))
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  -- progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole {m = ✓} x x₁) = I IEHole
  progress (TAEHole {σ = σ} {u = u} {m = ✗}  x x₁) = S (⦇⦈⟨ u , σ , ✓ ⟩ , {!!})
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V VConst = {!!} -- I (INEHole (FVal VConst))
  progress (TANEHole x₁ (TALam D) x₂) | V VLam = {!!} -- I (INEHole (FVal VLam))
  progress (TANEHole x₁ D x₂) | I x = {!!} -- I (INEHole (FIndet x))
  progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  progress (TANEHole x₃ D x₄) | S (d , Step x x₁ x₂) = S (_ , (Step (FNEHole x) x₁ (FNEHole x₂)))
  progress (TACast D x)
    with progress D
  progress (TACast TAConst TCRefl)  | V VConst = {!!}
  progress (TACast TAConst TCHole2) | V VConst = {!!}
  progress (TACast D x₁) | V VLam = {!x₁!}
  progress (TACast D x₁) | I x = I (ICast x)
  progress (TACast D x₁) | E x = E (ECastProp x)
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S ( _ , Step (FCast x) x₁ (FCast x₂))

open import Nat
open import Prelude
open import List
open import core
open import contexts

module progress where

  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → Δ ⊢ d err → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d Δ
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | _
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp (TALam D1) MAArr D2) | V VLam | I x₁ = S (_ , Step (FAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!})
  progress (TAAp D1 x₂ D2) | _ | E x₁ = E (EAp2 x₁)
  progress (TAAp D1 x₂ D2) | E x | _ = E (EAp1 x)
  -- progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I IEHole | V x₁ = I (IAp IEHole (FVal x₁))
  progress (TAAp D1 x₂ D2) | I (INEHole x) | V x₁ = I (IAp (INEHole x) (FVal x₁))
  progress (TAAp D1 x₃ D2) | I (IAp x x₁) | V x₂ = I (IAp (IAp x x₁) (FVal x₂))
  progress (TAAp D1 x₂ D2) | I (ICast x) | V x₁ = I (IAp (ICast x) (FVal x₁))
  progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
  progress (TAAp {d1 = d1} D1 x₄ D2) | _ | S (d , Step x₁ x₂ x₃) = S ((d1 ∘ d) , (Step {!!} (ITLam (FIndet {!!})) {!!}))
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  -- progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole x x₁) = I IEHole
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V VConst = I (INEHole (FVal VConst))
  progress (TANEHole x₁ (TALam D) x₂) | V VLam = I (INEHole (FVal VLam))
  progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  progress (TANEHole x₃ D x₄) | S (d , Step x x₁ x₂) = S (_ , (Step (FNEHole x) x₁ (FNEHole x₂)))
  progress (TACast D x)
    with progress D
  progress (TACast TAConst TCRefl)  | V VConst = {!!}
  progress (TACast TAConst TCHole2) | V VConst = {!!}
  progress (TACast D x₁) | V VLam = {!x₁!}
  progress (TACast D x₁) | I x = I (ICast x)
  progress (TACast D x₁) | E x = E (ECastProp x)
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S ( _ , Step (FCast x) x₁ (FCast x₂))


_>>_ is no longer a definition this the CBV semantics was getting in the way

module FFI.JS where

open import Data.Empty       public renaming (⊥ to 𝟘)
open import Data.Unit.Base   public renaming (⊤ to 𝟙)
open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List; []; _∷_)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)
open import Function         using (id; _∘_)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

postulate
  Number   : Set
  JSArray  : Set → Set
  JSObject : Set
  JSValue  : Set

postulate readNumber : String → Number
{-# COMPILED_JS readNumber Number #-}

postulate 0N : Number
{-# COMPILED_JS 0N 0 #-}

postulate 1N : Number
{-# COMPILED_JS 1N 1 #-}

postulate 2N : Number
{-# COMPILED_JS 2N 2 #-}

postulate 4N : Number
{-# COMPILED_JS 4N 4 #-}

postulate 8N : Number
{-# COMPILED_JS 8N 8 #-}

postulate 16N : Number
{-# COMPILED_JS 16N 16 #-}

postulate 32N : Number
{-# COMPILED_JS 32N 32 #-}

postulate 64N : Number
{-# COMPILED_JS 64N 64 #-}

postulate 128N : Number
{-# COMPILED_JS 128N 128 #-}

postulate 256N : Number
{-# COMPILED_JS 256N 256 #-}

postulate 512N : Number
{-# COMPILED_JS 512N 512 #-}

postulate 1024N : Number
{-# COMPILED_JS 1024N 1024 #-}

postulate 2048N : Number
{-# COMPILED_JS 2048N 2048 #-}

postulate 4096N : Number
{-# COMPILED_JS 4096N 4096 #-}

postulate _+_ : Number → Number → Number
{-# COMPILED_JS _+_ function(x) { return function(y) { return x + y; }; } #-}

postulate _−_ : Number → Number → Number
{-# COMPILED_JS _−_ function(x) { return function(y) { return x - y; }; } #-}

postulate _*_ : Number → Number → Number
{-# COMPILED_JS _*_ function(x) { return function(y) { return x * y; }; } #-}

postulate _/_ : Number → Number → Number
{-# COMPILED_JS _/_ function(x) { return function(y) { return x / y; }; } #-}

infixr 5  _++_
postulate _++_ : String → String → String
{-# COMPILED_JS _++_ function(x) { return function(y) { return x + y; }; } #-}

postulate _+JS_ : JSValue → JSValue → JSValue
{-# COMPILED_JS _+JS_ function(x) { return function(y) { return x + y; }; } #-}

postulate _≤JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≤JS_ function(x) { return function(y) { return x <= y; }; } #-}

postulate _<JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _<JS_ function(x) { return function(y) { return x < y; }; } #-}

postulate _>JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _>JS_ function(x) { return function(y) { return x > y; }; } #-}

postulate _≥JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≥JS_ function(x) { return function(y) { return x >= y; }; } #-}

postulate _===_ : JSValue → JSValue → Bool
{-# COMPILED_JS _===_ function(x) { return function(y) { return x === y; }; } #-}

postulate reverse : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS reverse function(ty) { return function(x) { return x.reverse(); }; } #-}

postulate sort : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS sort function(ty) { return function(x) { return x.sort(); }; } #-}

postulate split : (sep target : String) → JSArray String
{-# COMPILED_JS split function(sep) { return function(target) { return target.split(sep); }; } #-}

postulate join : (sep : String)(target : JSArray String) → String
{-# COMPILED_JS join function(sep) { return function(target) { return target.join(sep); }; } #-}

postulate substring : String → Number → Number → String
{-# COMPILED_JS substring require("libagda").substring #-}

-- substring with only one argument provided
postulate substring1 : String → Number → String
{-# COMPILED_JS substring1 require("libagda").substring1 #-}

postulate fromList : {A B : Set}(xs : List A)(fromElt : A → B) → JSArray B
{-# COMPILED_JS fromList require("libagda").fromList #-}

postulate length : String → Number
{-# COMPILED_JS length function(s) { return s.length; } #-}

postulate JSON-stringify : JSValue → String
{-# COMPILED_JS JSON-stringify JSON.stringify #-}

postulate JSON-parse : String → JSValue
{-# COMPILED_JS JSON-parse JSON.parse #-}

postulate toString : JSValue → String
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}

postulate fromBool : Bool → JSValue
{-# COMPILED_JS fromBool function(x) { return x; } #-}

postulate fromString : String → JSValue
{-# COMPILED_JS fromString function(x) { return x; } #-}

postulate fromChar : Char → JSValue
{-# COMPILED_JS fromChar String #-}

postulate Char▹String : Char → String
{-# COMPILED_JS Char▹String String #-}

postulate fromNumber : Number → JSValue
{-# COMPILED_JS fromNumber function(x) { return x; } #-}

postulate fromJSArray : {A : Set} → JSArray A → JSValue
{-# COMPILED_JS fromJSArray function(ty) { return function(x) { return x; }; } #-}

postulate fromJSObject : JSObject → JSValue
{-# COMPILED_JS fromJSObject function(x) { return x; } #-}

postulate objectFromList : {A : Set}(xs : List A)(fromKey : A → String)(fromVal : A → JSValue) → JSObject
{-# COMPILED_JS objectFromList require("libagda").objectFromList #-}

postulate decodeJSArray : {A B : Set}(arr : JSArray A)(fromElt : Number → A → B) → List B
{-# COMPILED_JS decodeJSArray require("libagda").decodeJSArray #-}

postulate String▹Char : String → Char
{-# COMPILED_JS String▹Char require("libagda").StringToChar #-}

postulate checkTypeof : (type : String) → JSValue → JSValue
{-# COMPILED_JS checkTypeof require("libagda").checkTypeof #-}

postulate castNumber : JSValue → Number
{-# COMPILED_JS castNumber require("libagda").checkTypeof("number") #-}

postulate castString : JSValue → String
{-# COMPILED_JS castString require("libagda").checkTypeof("string") #-}

postulate castJSArray : JSValue → JSArray JSValue
{-# COMPILED_JS castJSArray require("libagda").checkTypeof("array") #-}

postulate castJSObject : JSValue → JSObject
{-# COMPILED_JS castJSObject require("libagda").checkTypeof("object") #-}

postulate castBool : JSValue → Bool
{-# COMPILED_JS castBool require("libagda").checkTypeof("bool") #-}

castChar : JSValue → Char
castChar = String▹Char ∘ castString

postulate nullJS : JSValue
{-# COMPILED_JS nullJS null #-}

postulate undefinedJS : JSValue
{-# COMPILED_JS undefinedJS undefined #-}

postulate _·[_] : JSValue → JSValue → JSValue
{-# COMPILED_JS _·[_] require("libagda").readProp #-}

postulate _Array[_] : {A : Set} → JSArray A → Number → A
{-# COMPILED_JS _Array[_] function(ty) { return require("libagda").readProp; } #-}

-- Writes 'msg' and 'inp' to the console and then returns `f inp`
postulate trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
{-# COMPILED_JS trace require("libagda").trace #-}

-- Same type as trace but does not print anything
-- Usage:
--   open import FFI.JS renaming (no-trace to trace)
no-trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
no-trace _ inp f = f inp

postulate throw : {A : Set} → String → A → A
{-# COMPILED_JS throw require("libagda").throw #-}

postulate is-null : JSValue → Bool
{-# COMPILED_JS is-null function(x) { return (x == null); } #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number → Value
  bool   : Bool   → Value
  null   : Value

Object = List (String × JSValue)

postulate fromValue : Value → JSValue
{-# COMPILED_JS fromValue require("libagda").fromValue #-}

-- TODO we could make it a COMPILED type and remove the encoding by using JSValue as the internal repr.
data ValueView : Set₀ where
  array  : JSArray JSValue → ValueView
  object : JSObject        → ValueView
  string : String          → ValueView
  number : Number          → ValueView
  bool   : Bool            → ValueView
  null   : ValueView

-- TODO not yet tested
postulate viewJSValue : JSValue → ValueView
{-# COMPILED_JS viewJSValue require("libagda").viewJSValue #-}

Bool▹String : Bool → String
Bool▹String true  = "true"
Bool▹String false = "false"

List▹String : List Char → String
List▹String xs = join "" (fromList xs Char▹String)

String▹List : String → List Char
String▹List s = decodeJSArray (split "" s) (λ _ → String▹Char)

Number▹String : Number → String
Number▹String = toString ∘ fromNumber

JSArray▹ListString : {A : Set} → JSArray A → List A
JSArray▹ListString a = decodeJSArray a (λ _ → id)

fromObject : Object → JSObject
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_<Char_ : Char → Char → Bool
x <Char y = fromChar x <JS fromChar y

_>Char_ : Char → Char → Bool
x >Char y = fromChar x >JS fromChar y

_≥Char_ : Char → Char → Bool
x ≥Char y = fromChar x ≥JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_<String_ : String → String → Bool
x <String y = fromString x <JS fromString y

_>String_ : String → String → Bool
x >String y = fromString x >JS fromString y

_≥String_ : String → String → Bool
x ≥String y = fromString x ≥JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_<Number_ : Number → Number → Bool
x <Number y = fromNumber x <JS fromNumber y

_>Number_ : Number → Number → Bool
x >Number y = fromNumber x >JS fromNumber y

_≥Number_ : Number → Number → Bool
x ≥Number y = fromNumber x ≥JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

_·«_»A : JSValue → String → JSArray JSValue
v ·« s »A = castJSArray (v ·« s »)

trace-call : {A B : Set} → String → (A → B) → A → B
trace-call s f x = trace s (f x) id

postulate JSCmd : Set → Set

Callback1 : Set → Set
Callback1 A = JSCmd ((A → 𝟘) → 𝟘)

JS! : Set
JS! = Callback1 𝟙

Callback2 : Set → Set → Set
Callback2 A B = JSCmd ((A → B → 𝟘) → 𝟘)

postulate assert : Bool → JS!
{-# COMPILED_JS assert require("libagda").assert #-}

infixr 0  _>>_ _!₁_ _!₂_

postulate _!₁_ : {A : Set}(cmd : Callback1 A)(cb : A → JS!) → JS!
{-# COMPILED_JS _!₁_ require("libagda").call1 #-}

postulate _!₂_ : {A B : Set}(cmd : JSCmd ((A → B → 𝟘) → 𝟘))(cb : A → B → JS!) → JS!
{-# COMPILED_JS _!₂_ require("libagda").call2 #-}

postulate _>>_ : JS! → JS! → JS!
{-# COMPILED_JS _>>_ function(x) { return function (y) { return require("libagda").call1("*")(x)(function (z) { return y; }); }; } #-}
-- Unfortunately so far such a definition can have a poor run-time semantics, where the second
-- is needlessly computed. Worse given the use of partial functions such as assert, throw,
-- cast{String,Number...} this can lead to abort the program.
-- cmd >> cont = cmd !₁ λ _ → cont

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

module FFI.JS where

open import Data.Empty       public renaming (⊥ to 𝟘)
open import Data.Unit.Base   public renaming (⊤ to 𝟙)
open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List; []; _∷_)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)
open import Function         using (id; _∘_)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

postulate
  Number   : Set
  JSArray  : Set → Set
  JSObject : Set
  JSValue  : Set

postulate readNumber : String → Number
{-# COMPILED_JS readNumber Number #-}

postulate 0N : Number
{-# COMPILED_JS 0N 0 #-}

postulate 1N : Number
{-# COMPILED_JS 1N 1 #-}

postulate 2N : Number
{-# COMPILED_JS 2N 2 #-}

postulate 4N : Number
{-# COMPILED_JS 4N 4 #-}

postulate 8N : Number
{-# COMPILED_JS 8N 8 #-}

postulate 16N : Number
{-# COMPILED_JS 16N 16 #-}

postulate 32N : Number
{-# COMPILED_JS 32N 32 #-}

postulate 64N : Number
{-# COMPILED_JS 64N 64 #-}

postulate 128N : Number
{-# COMPILED_JS 128N 128 #-}

postulate 256N : Number
{-# COMPILED_JS 256N 256 #-}

postulate 512N : Number
{-# COMPILED_JS 512N 512 #-}

postulate 1024N : Number
{-# COMPILED_JS 1024N 1024 #-}

postulate 2048N : Number
{-# COMPILED_JS 2048N 2048 #-}

postulate 4096N : Number
{-# COMPILED_JS 4096N 4096 #-}

postulate _+_ : Number → Number → Number
{-# COMPILED_JS _+_ function(x) { return function(y) { return x + y; }; } #-}

postulate _−_ : Number → Number → Number
{-# COMPILED_JS _−_ function(x) { return function(y) { return x - y; }; } #-}

postulate _*_ : Number → Number → Number
{-# COMPILED_JS _*_ function(x) { return function(y) { return x * y; }; } #-}

postulate _/_ : Number → Number → Number
{-# COMPILED_JS _/_ function(x) { return function(y) { return x / y; }; } #-}

infixr 5  _++_
postulate _++_ : String → String → String
{-# COMPILED_JS _++_ function(x) { return function(y) { return x + y; }; } #-}

postulate _+JS_ : JSValue → JSValue → JSValue
{-# COMPILED_JS _+JS_ function(x) { return function(y) { return x + y; }; } #-}

postulate _≤JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≤JS_ function(x) { return function(y) { return x <= y; }; } #-}

postulate _<JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _<JS_ function(x) { return function(y) { return x < y; }; } #-}

postulate _>JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _>JS_ function(x) { return function(y) { return x > y; }; } #-}

postulate _≥JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≥JS_ function(x) { return function(y) { return x >= y; }; } #-}

postulate _===_ : JSValue → JSValue → Bool
{-# COMPILED_JS _===_ function(x) { return function(y) { return x === y; }; } #-}

postulate reverse : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS reverse function(ty) { return function(x) { return x.reverse(); }; } #-}

postulate sort : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS sort function(ty) { return function(x) { return x.sort(); }; } #-}

postulate split : (sep target : String) → JSArray String
{-# COMPILED_JS split function(sep) { return function(target) { return target.split(sep); }; } #-}

postulate join : (sep : String)(target : JSArray String) → String
{-# COMPILED_JS join function(sep) { return function(target) { return target.join(sep); }; } #-}

postulate substring : String → Number → Number → String
{-# COMPILED_JS substring require("libagda").substring #-}

-- substring with only one argument provided
postulate substring1 : String → Number → String
{-# COMPILED_JS substring1 require("libagda").substring1 #-}

postulate fromList : {A B : Set}(xs : List A)(fromElt : A → B) → JSArray B
{-# COMPILED_JS fromList require("libagda").fromList #-}

postulate length : String → Number
{-# COMPILED_JS length function(s) { return s.length; } #-}

postulate JSON-stringify : JSValue → String
{-# COMPILED_JS JSON-stringify JSON.stringify #-}

postulate JSON-parse : String → JSValue
{-# COMPILED_JS JSON-parse JSON.parse #-}

postulate toString : JSValue → String
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}

postulate fromBool : Bool → JSValue
{-# COMPILED_JS fromBool function(x) { return x; } #-}

postulate fromString : String → JSValue
{-# COMPILED_JS fromString function(x) { return x; } #-}

postulate fromChar : Char → JSValue
{-# COMPILED_JS fromChar String #-}

postulate Char▹String : Char → String
{-# COMPILED_JS Char▹String String #-}

postulate fromNumber : Number → JSValue
{-# COMPILED_JS fromNumber function(x) { return x; } #-}

postulate fromJSArray : {A : Set} → JSArray A → JSValue
{-# COMPILED_JS fromJSArray function(ty) { return function(x) { return x; }; } #-}

postulate fromJSObject : JSObject → JSValue
{-# COMPILED_JS fromJSObject function(x) { return x; } #-}

postulate objectFromList : {A : Set}(xs : List A)(fromKey : A → String)(fromVal : A → JSValue) → JSObject
{-# COMPILED_JS objectFromList require("libagda").objectFromList #-}

postulate decodeJSArray : {A B : Set}(arr : JSArray A)(fromElt : Number → A → B) → List B
{-# COMPILED_JS decodeJSArray require("libagda").decodeJSArray #-}

postulate String▹Char : String → Char
{-# COMPILED_JS String▹Char require("libagda").StringToChar #-}

postulate checkTypeof : (type : String) → JSValue → JSValue
{-# COMPILED_JS checkTypeof require("libagda").checkTypeof #-}

postulate castNumber : JSValue → Number
{-# COMPILED_JS castNumber require("libagda").checkTypeof("number") #-}

postulate castString : JSValue → String
{-# COMPILED_JS castString require("libagda").checkTypeof("string") #-}

postulate castJSArray : JSValue → JSArray JSValue
{-# COMPILED_JS castJSArray require("libagda").checkTypeof("array") #-}

postulate castJSObject : JSValue → JSObject
{-# COMPILED_JS castJSObject require("libagda").checkTypeof("object") #-}

postulate castBool : JSValue → Bool
{-# COMPILED_JS castBool require("libagda").checkTypeof("bool") #-}

castChar : JSValue → Char
castChar = String▹Char ∘ castString

postulate nullJS : JSValue
{-# COMPILED_JS nullJS null #-}

postulate undefinedJS : JSValue
{-# COMPILED_JS undefinedJS undefined #-}

postulate _·[_] : JSValue → JSValue → JSValue
{-# COMPILED_JS _·[_] require("libagda").readProp #-}

postulate _Array[_] : {A : Set} → JSArray A → Number → A
{-# COMPILED_JS _Array[_] function(ty) { return require("libagda").readProp; } #-}

-- Writes 'msg' and 'inp' to the console and then returns `f inp`
postulate trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
{-# COMPILED_JS trace require("libagda").trace #-}

-- Same type as trace but does not print anything
-- Usage:
--   open import FFI.JS renaming (no-trace to trace)
no-trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
no-trace _ inp f = f inp

postulate throw : {A : Set} → String → A → A
{-# COMPILED_JS throw require("libagda").throw #-}

postulate is-null : JSValue → Bool
{-# COMPILED_JS is-null function(x) { return (x == null); } #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number → Value
  bool   : Bool   → Value
  null   : Value

Object = List (String × JSValue)

postulate fromValue : Value → JSValue
{-# COMPILED_JS fromValue require("libagda").fromValue #-}

-- TODO we could make it a COMPILED type and remove the encoding by using JSValue as the internal repr.
data ValueView : Set₀ where
  array  : JSArray JSValue → ValueView
  object : JSObject        → ValueView
  string : String          → ValueView
  number : Number          → ValueView
  bool   : Bool            → ValueView
  null   : ValueView

-- TODO not yet tested
postulate viewJSValue : JSValue → ValueView
{-# COMPILED_JS viewJSValue require("libagda").viewJSValue #-}

Bool▹String : Bool → String
Bool▹String true  = "true"
Bool▹String false = "false"

List▹String : List Char → String
List▹String xs = join "" (fromList xs Char▹String)

String▹List : String → List Char
String▹List s = decodeJSArray (split "" s) (λ _ → String▹Char)

Number▹String : Number → String
Number▹String = toString ∘ fromNumber

JSArray▹ListString : {A : Set} → JSArray A → List A
JSArray▹ListString a = decodeJSArray a (λ _ → id)

fromObject : Object → JSObject
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_<Char_ : Char → Char → Bool
x <Char y = fromChar x <JS fromChar y

_>Char_ : Char → Char → Bool
x >Char y = fromChar x >JS fromChar y

_≥Char_ : Char → Char → Bool
x ≥Char y = fromChar x ≥JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_<String_ : String → String → Bool
x <String y = fromString x <JS fromString y

_>String_ : String → String → Bool
x >String y = fromString x >JS fromString y

_≥String_ : String → String → Bool
x ≥String y = fromString x ≥JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_<Number_ : Number → Number → Bool
x <Number y = fromNumber x <JS fromNumber y

_>Number_ : Number → Number → Bool
x >Number y = fromNumber x >JS fromNumber y

_≥Number_ : Number → Number → Bool
x ≥Number y = fromNumber x ≥JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

_·«_»A : JSValue → String → JSArray JSValue
v ·« s »A = castJSArray (v ·« s »)

trace-call : {A B : Set} → String → (A → B) → A → B
trace-call s f x = trace s (f x) id

postulate JSCmd : Set → Set

Callback1 : Set → Set
Callback1 A = JSCmd ((A → 𝟘) → 𝟘)

JS! : Set
JS! = Callback1 𝟙

Callback2 : Set → Set → Set
Callback2 A B = JSCmd ((A → B → 𝟘) → 𝟘)

postulate assert : Bool → JS!
{-# COMPILED_JS assert require("libagda").assert #-}

infixr 0  _>>_ _!₁_ _!₂_

postulate _!₁_ : {A : Set}(cmd : Callback1 A)(cb : A → JS!) → JS!
{-# COMPILED_JS _!₁_ require("libagda").call1 #-}

postulate _!₂_ : {A B : Set}(cmd : JSCmd ((A → B → 𝟘) → 𝟘))(cb : A → B → JS!) → JS!
{-# COMPILED_JS _!₂_ require("libagda").call2 #-}

_>>_ : JS! → JS! → JS!
cmd >> cont = cmd !₁ λ _ → cont

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


Added x<Sy→x<y∨x≡y.

Added x<Sy→x<y∨x≡y.

Ignore-this: 7a3604db707115ffe1d99d7a2508bcb1

darcs-hash:20100525024018-3bd4e-e83f8f49f5bd7c151711a82f9c9536f9203f8174.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Equalities.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

0≤x : {n : D} → N n → LE zero n
0≤x Nn = x≥0 Nn

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<0 (sN Nn) Sn<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}

postulate
  ¬0>x : {n : D} → N n → ¬ (GT zero n)
{-# ATP prove ¬0>x x≥0 #-}

postulate
  ¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
{-# ATP prove ¬S≤0 #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
    postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
    postulate prf : ¬ (LT m m) → ⊥
    {-# ATP prove prf #-}

x≤x : {m : D} → N m → LE m m
x≤x zN          = lt-00
x≤x (sN {m} Nm) = prf (x≤x Nm)
  where
    postulate prf : LE m m → LE (succ m) (succ m)
    {-# ATP prove prf #-}

-- TODO: Why not a dot pattern?
x≡y→x≤y : {m n : D} → N m → N n → m ≡ n → LE m n
x≡y→x≤y Nm Nn refl = x≤x Nm

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn)          _     = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE m n →
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

x<y→Sx≤y : {m n : D} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm zN m<0 = ⊥-elim (¬x<0 Nm m<0)

x<y→Sx≤y zN (sN zN) _ = S0≤S0
  where
    postulate S0≤S0 : LE (succ zero) (succ zero)
    {-# ATP prove S0≤S0 #-}

x<y→Sx≤y zN (sN (sN {n} Nn)) _ = S0≤SSn
  where
    postulate S0≤SSn : LE (succ zero) (succ (succ n))
    {-# ATP prove S0≤SSn #-}

x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→Sx≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE (succ m) n → LE (succ (succ m)) (succ n)
    {-# ATP prove prf #-}

Sx≤y→x<y : {m n : D} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim (¬S≤0 Sm≤0)
Sx≤y→x<y zN          (sN {n} Nn) _      = lt-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn = prf (Sx≤y→x<y Nm Nn Sm≤n)
  where
    postulate Sm≤n : LE (succ m) n
    {-# ATP prove Sm≤n #-}

    postulate prf : LT m n → LT (succ m) (succ n)
    {-# ATP prove prf #-}

<-trans : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
<-trans zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
<-trans zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
<-trans (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
<-trans (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  prf (<-trans Nm Nn No m<n n<o)

  where
    postulate prf : LT m o → LT (succ m) (succ o)
    {-# ATP prove prf #-}

    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate n<o : LT n o
    {-# ATP prove n<o #-}

≤-trans : {m n o : D} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim (¬S≤0 Sm≤0)
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim (¬S≤0 Sn≤0)
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  prf (≤-trans Nm Nn No m≤n n≤o)
    where
      postulate m≤n : LE m n
      {-# ATP prove m≤n #-}

      postulate n≤o : LE n o
      {-# ATP prove n≤o #-}

      postulate prf : LE m o → LE (succ m) (succ o)
      {-# ATP prove prf #-}

postulate
  Sx≤Sy→x≤y : {m n : D} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
    postulate prf : LE m (m + n) → LE (succ m) (succ m + n)
    {-# ATP prove prf #-}

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m - zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero - succ n) (succ zero)
    {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
    postulate prf : LT (m - n) (succ m) →
                    LT (succ m - succ n) (succ (succ m))
    {-# ATP prove prf <-trans minus-N x<Sx sN #-}

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m - zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m - n) + n ≡ m →
                    (succ m - succ n) + succ n ≡ succ m
    {-# ATP prove prf +-comm minus-N sN #-}

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n - zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity minus-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y-x+x≡y Nm Nn m≤n )
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n - m) + m ≡ n →
                    (succ n - succ m) + succ m ≡ succ n
    {-# ATP prove prf +-comm minus-N sN #-}

x<y→x<Sy : {m n : D} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim (¬x<0 Nm m<0)
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = lt-0S (succ n)
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x<Sy Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LT m (succ n) → LT (succ m) (succ (succ n))
    {-# ATP prove prf #-}

x<Sy→x<y∨x≡y : {m n : D} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (lt-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim (¬x<0 Nm (trans (sym (lt-SS m zero)) Sm<S0))
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (lt-SS m n) m<n))
  , (λ m≡n → inj₂ (x≡y→Sx≡Sy m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym (lt-SS m (succ n))) Sm<SSn)

postulate
  x<y→y≡z→x<z : {m n o : D} → N m → N n → N o → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : {m n o : D} → N m → N n → N o → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  ¬xy<00 : {m n : D} → N m → N n → ¬ (LT₂ m n zero zero)
{-# ATP prove ¬xy<00 ¬x<0 #-}

postulate
  ¬Sxy₁<0y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
{-# ATP prove ¬Sxy₁<0y₂ ¬x<0 sN #-}

postulate
  ¬0Sx<00 : {m : D} → N m → ¬ (LT₂ zero (succ m) zero zero)
{-# ATP prove ¬0Sx<00 ¬x<0 sN #-}

postulate
  x₁y<x₂0→x₁<x₂ : {m₁ n m₂ : D} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
{-# ATP prove x₁y<x₂0→x₁<x₂ ¬x<0 #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ ¬x<0 #-}

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

0≤x : {n : D} → N n → LE zero n
0≤x Nn = x≥0 Nn

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<0 (sN Nn) Sn<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}

postulate
  ¬0>x : {n : D} → N n → ¬ (GT zero n)
{-# ATP prove ¬0>x x≥0 #-}

postulate
  ¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
{-# ATP prove ¬S≤0 #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
    postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
    postulate prf : ¬ (LT m m) → ⊥
    {-# ATP prove prf #-}

x≤x : {m : D} → N m → LE m m
x≤x zN          = lt-00
x≤x (sN {m} Nm) = prf (x≤x Nm)
  where
    postulate prf : LE m m → LE (succ m) (succ m)
    {-# ATP prove prf #-}

-- TODO: Why not a dot pattern?
x≡y→x≤y : {m n : D} → N m → N n → m ≡ n → LE m n
x≡y→x≤y Nm Nn refl = x≤x Nm

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn)          _     = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE m n →
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

x<y→Sx≤y : {m n : D} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm zN m<0 = ⊥-elim (¬x<0 Nm m<0)

x<y→Sx≤y zN (sN zN) _ = S0≤S0
  where
    postulate S0≤S0 : LE (succ zero) (succ zero)
    {-# ATP prove S0≤S0 #-}

x<y→Sx≤y zN (sN (sN {n} Nn)) _ = S0≤SSn
  where
    postulate S0≤SSn : LE (succ zero) (succ (succ n))
    {-# ATP prove S0≤SSn #-}

x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→Sx≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE (succ m) n → LE (succ (succ m)) (succ n)
    {-# ATP prove prf #-}

Sx≤y→x<y : {m n : D} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim (¬S≤0 Sm≤0)
Sx≤y→x<y zN          (sN {n} Nn) _      = lt-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn = prf (Sx≤y→x<y Nm Nn Sm≤n)
  where
    postulate Sm≤n : LE (succ m) n
    {-# ATP prove Sm≤n #-}

    postulate prf : LT m n → LT (succ m) (succ n)
    {-# ATP prove prf #-}

<-trans : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
<-trans zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
<-trans zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
<-trans (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
<-trans (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  prf (<-trans Nm Nn No m<n n<o)

  where
    postulate prf : LT m o → LT (succ m) (succ o)
    {-# ATP prove prf #-}

    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate n<o : LT n o
    {-# ATP prove n<o #-}

≤-trans : {m n o : D} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim (¬S≤0 Sm≤0)
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim (¬S≤0 Sn≤0)
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  prf (≤-trans Nm Nn No m≤n n≤o)
    where
      postulate m≤n : LE m n
      {-# ATP prove m≤n #-}

      postulate n≤o : LE n o
      {-# ATP prove n≤o #-}

      postulate prf : LE m o → LE (succ m) (succ o)
      {-# ATP prove prf #-}

postulate
  Sx≤Sy→x≤y : {m n : D} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
    postulate prf : LE m (m + n) → LE (succ m) (succ m + n)
    {-# ATP prove prf #-}

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m - zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero - succ n) (succ zero)
    {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
    postulate prf : LT (m - n) (succ m) →
                    LT (succ m - succ n) (succ (succ m))
    {-# ATP prove prf <-trans minus-N x<Sx sN #-}

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m - zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m - n) + n ≡ m →
                    (succ m - succ n) + succ n ≡ succ m
    {-# ATP prove prf +-comm minus-N sN #-}

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n - zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity minus-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y-x+x≡y Nm Nn m≤n )
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n - m) + m ≡ n →
                    (succ n - succ m) + succ m ≡ succ n
    {-# ATP prove prf +-comm minus-N sN #-}

x<y→x<Sy : {m n : D} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim (¬x<0 Nm m<0)
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = lt-0S (succ n)
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x<Sy Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LT m (succ n) → LT (succ m) (succ (succ n))
    {-# ATP prove prf #-}

postulate
  x<y→y≡z→x<z : {m n o : D} → N m → N n → N o → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : {m n o : D} → N m → N n → N o → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  ¬xy<00 : {m n : D} → N m → N n → ¬ (LT₂ m n zero zero)
{-# ATP prove ¬xy<00 ¬x<0 #-}

postulate
  ¬Sxy₁<0y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
{-# ATP prove ¬Sxy₁<0y₂ ¬x<0 sN #-}

postulate
  ¬0Sx<00 : {m : D} → N m → ¬ (LT₂ zero (succ m) zero zero)
{-# ATP prove ¬0Sx<00 ¬x<0 sN #-}

postulate
  x₁y<x₂0→x₁<x₂ : {m₁ n m₂ : D} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
{-# ATP prove x₁y<x₂0→x₁<x₂ ¬x<0 #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ ¬x<0 #-}

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}


Rename E≤E into E<E

Rename E≤E into E<E

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Sum

open import Function

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

record ]0,1[-ops (]0,1[ : Set) (_<E_ : ]0,1[ → ]0,1[ → Set) : Set where
  constructor mk

  field
    -- 1E : ]0,1]
    1+_/1+x_ : ℕ → ℕ → ]0,1[
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[
    1-E_ : ]0,1[ → ]0,1[

   -- proofs <E
  field
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  field
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[){y : ]0,1[} → (x ·E y) <E y
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  -- proofs ≡ maybe should be some Equivalence ≈
  field
    +E-sym : (x y : ]0,1[) → x +E y ≡ y +E x
    +E-assoc : (x y z : ]0,1[) → (x +E y) +E z ≡ x +E (y +E z)
    ·/E-identity : (x : ]0,1[){y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

module ]0,1[-ℚ where
  data ]0,1[ : Set where
    1+_/2+x+_ : ℕ → ℕ → ]0,1[
  -- toℚ : ]0,1] → ℚ
  -- toℚ (1+ x /1+x+ y) = (1 + x) /ℚ (1 + x + y)

  postulate
    _<E_ : ]0,1[ → ]0,1[ → Set
  -- (1+ x /1+x+ y) ≤E (1+ x' /1+x+ y') = ?
  -- (1 + x' + y') * (1 + x) ≤E (1 + x + y) * (1 + x') = ?

  -- 1 - ((1 + x) / (2 + x + y))
  --  ≡ (2 + x + y - (1 + x)) / (2 + x + y)
  --  ≡ (1 + y) / (2 + x + y)
  --  ≡ (1 + y) / (2 + y + x)
  1-E_ : ]0,1[ → ]0,1[
  1-E (1+ x /2+x+ y) = 1+ y /2+x+ x

  -- ((1 + x) / (2 + x + y)) · ((1 + x') / (2 + x' + y'))
  --  ≡ ((1 + x) · (1 + x')) / ((2 + x + y) · (2 + x' + y'))
  --  ≡ (1 + x + x' + x · x') / (4 + 2x + 2y + 2x' + 2y' + xx' + xy' + yx' + yy')
  --  ≡ (1 + (x + x' + xx')) / (2 + (x + x' + xx') + (2 + x + 2y + x' + xy' + yx' + yy'))
  _·E_ : ]0,1[ → ]0,1[ → ]0,1[
  (1+ x /2+x+ y) ·E (1+ x' /2+x+ y') = 1+ x'' /2+x+ y''
    where x'' = x + x' + x * x'
          y'' = 2 + x + 2 * y + x' + x * y' + y * x' + y * y'

  -- ((1 + x) / (2 + x + y)) / ((1 + x') / (2 + x' + y'))
  --   ≡ ((1 + x) · (2 + x' + y')) / ((1 + x') · (2 + x + y))
  --   ≡ (2 + x' + y' + 2x + xx' + xy') / (2 + x + y + 2x' + xx' + x'y)
  --   ≡ (1 + (1 + x' + y' + 2x + xx' + xy')) / (2 + (1 + x' + y' + 2x + xx' + xy') + y + x' + x'y - (1 + y' + x + xy'))
  --   ok provided that:
  --   ((1 + x) / (2 + x + y)) < ((1 + x') / (2 + x' + y'))
  --   implies
  --   (1 + y' + x + xy') ≤ (y + x' + x'y)
  --   which remains to be checked
  _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[
  (1+ x /2+x+ y) /E (1+ x' /2+x+ y') < _ > = 1+ x'' /2+x+ y''
    where x'' = 1 + x' + y' + 2 * x + x * x' + x * y'
          y'' = y + x' + x' * y ∸ 1 ∸ y' ∸ x ∸ x * y'

  postulate
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[

  postulate
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  postulate
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[) {x₁ : ]0,1[} → (x ·E x₁) <E x₁
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  postulate
    +E-sym : (x x₁ : ]0,1[) → x +E x₁ ≡ x₁ +E x
    +E-assoc : (x x₁ x₂ : ]0,1[) → (x +E x₁) +E x₂ ≡ x +E (x₁ +E x₂)
    ·/E-identity : (x : ]0,1[) {y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

  ops : ]0,1[-ops ]0,1[ _<E_
  ops = mk 1+_/2+x+_ _+E_ _·E_ _/E_<_> 1-E_ <E-trans +E-mono₁ +E-mono₂ ·E-anti₁ ·E-anti₂ ·/E-assoc +E-sym +E-assoc ·/E-identity

module [0,1] {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_) where

  open ]0,1[-ops ]0,1[R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   1I : [0,1]
   _I : ]0,1[ → [0,1]

  data _≤I_ : [0,1] → [0,1] → Set where
    z≤n : ∀ {n} → 0I ≤I n
    n≤1 : ∀ {n} → n ≤I 1I
    E<E : ∀ {x y} → x <E y → (x I) ≤I (y I)
    E≡E : ∀ {x} → x I ≤I x I

  ≤I-refl : ∀ {x} → x ≤I x
  ≤I-refl {0I} = z≤n
  ≤I-refl {1I} = n≤1
  ≤I-refl {x I} = E≡E

  Pos : [0,1] → Set
  Pos 0I    = ⊥
  Pos 1I    = ⊤
  Pos (_ I) = ⊤

  Inc : [0,1] → Set
  Inc 0I = ⊥
  Inc 1I = ⊥
  Inc (x I) = ⊤

  _<_> : (x : [0,1]) → Inc x → ]0,1[
  0I < () >
  1I < () >
  (x I) < pos > = x

  1-I_ : [0,1] → [0,1]
  1-I 0I    = 1I
  1-I 1I    = 0I
  1-I (x I) = (1-E x) I

  _+I_ : [0,1] → [0,1] → [0,1]
  0I  +I x    = x
  x I +I 0I   = x I
  1I  +I _    = 1I -- troublesome
  x I +I 1I   = 1I -- troublesome
  x I +I x₁ I = (x +E x₁) I -- faithful

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  1I ·I y = y
  (x I) ·I 0I     = 0I
  (x I) ·I 1I     = x I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  -- 1/I1+_ : ℕ → [0,1]

  _/I_<_,_> : (x y : [0,1]) → x ≤I y → Pos y → [0,1]
  x /I 0I    < _        , () >
  x /I 1I    < _        , _  > = x
  0I /I _    < _        , _  > = 0I
  1I /I _ I  < ()       , _  >
  (x I) /I y I < E<E pf , _  > = (x /E y < pf >) I
  (x I) /I .x I < E≡E   , _  > = 1I

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  *-anti : (x : [0,1]){y z : [0,1]} → y ≤I z → x ·I y ≤I z
  *-anti 0I le = z≤n
  *-anti 1I le = le
  *-anti (x I) z≤n = z≤n
  *-anti (x I) n≤1 = n≤1
  *-anti (x I) (E<E pf) = E<E (·E-anti₂ x pf)
  *-anti (x I) E≡E = E<E (·E-anti₁ x)

  */-assoc : (x y z : [0,1])(pr : y ≤I z)(pos : Pos z) → (x ·I (y /I z < pr , pos >)) ≡ (x ·I y) /I z < *-anti x pr , pos >
  */-assoc x y 0I pr ()
  */-assoc x y 1I pr pos = refl
  */-assoc 0I y (z I) pr pos = refl
  */-assoc 1I y (z I) pr pos = refl
  */-assoc (x I) 0I (z I) pr pos = refl
  */-assoc (x I) 1I (z I) () pos
  */-assoc (x I) (y I) (z I) (E<E pf) pos = cong _I (·/E-assoc x y z pf)
  */-assoc (x I) (y I) (.y I) E≡E pos = cong _I (·/E-identity x)

  +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
  +I-sym 0I 0I = refl
  +I-sym 0I 1I = refl
  +I-sym 0I (x I) = refl
  +I-sym 1I 0I = refl
  +I-sym 1I 1I = refl
  +I-sym 1I (x I) = refl
  +I-sym (x I) 0I = refl
  +I-sym (x I) 1I = refl
  +I-sym (x I) (y I) = cong _I (+E-sym x y)

  +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)
  +I-assoc 0I y z = refl
  +I-assoc 1I y z = refl
  +I-assoc (x I) 0I z = refl
  +I-assoc (x I) 1I z = refl
  +I-assoc (x I) (y I) 0I = refl
  +I-assoc (x I) (y I) 1I = refl
  +I-assoc (x I) (y I) (z I) = cong _I (+E-assoc x y z)

  ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
  ≤I-trans z≤n le2 = z≤n
  ≤I-trans n≤1 n≤1 = n≤1
  ≤I-trans (E<E x₁) n≤1 = n≤1
  ≤I-trans (E<E x₁) (E<E x₂) = E<E (<E-trans x₁ x₂)
  ≤I-trans (E<E x₁) E≡E = E<E x₁
  ≤I-trans E≡E le2 = le2

  ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
  ≤I-mono 0I {z = z} le rewrite +I-sym z 0I = le
  ≤I-mono 1I {z = z} le rewrite +I-sym z 1I = n≤1
  ≤I-mono (x I) z≤n = z≤n
  ≤I-mono (x I) n≤1 = n≤1
  ≤I-mono (x I) (E<E x₂) = E<E (<E-trans x₂ (+E-mono₁ x))
  ≤I-mono (x I) E≡E = E<E (+E-mono₁ x)

  ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z
  ≤I-pres 0I le = le
  ≤I-pres 1I le = n≤1
  ≤I-pres (x I) {.0I} {0I} z≤n = E≡E
  ≤I-pres (x I) {.0I} {1I} z≤n = n≤1
  ≤I-pres (x I) {.0I} {x₁ I} z≤n = E<E (+E-mono₁ x₁)
  ≤I-pres (x I) n≤1 = n≤1
  ≤I-pres (x I) (E<E x₂) = E<E (+E-mono₂ x x₂)
  ≤I-pres (x I) E≡E = E≡E

module Univ {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_)
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1[R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP pmf []       = 0I
  sumP pmf (x ∷ xs) = (pmf x) +I (sumP pmf xs)

  record Distr : Set where
    constructor _,_
    field
      -- Probability mass function: http://en.wikipedia.org/wiki/Probability_mass_function
      pmf    : U → [0,1]
      sum≡1 : sumP pmf allU ≡ 1I

  module Prob (d : Distr) where
    open Distr d

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then pmf x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    _⊆_ : Event → Event → Set
    A ⊆ B = ∀ x → T(A x) → T(B x)

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    postulate
      Pr-mono : ∀ {A B} → A ⊆ B → Pr[ A ] ≤I Pr[ B ]

    ∪-lem : ∀ {A} B → A ⊆ (A ∪ B)
    ∪-lem {A} _ x with A x
    ... | true = id
    ... | false = λ()

    ∩-lem : ∀ A {B} → (A ∩ B) ⊆ B
    ∩-lem A x with A x
    ... | true  = id
    ... | false = λ()

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < Pr-mono (∩-lem A) , pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (pmf x) (sA₁ xs) (pmf x +I sA₂ xs)
                                | +I-sym (pmf x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (pmf x))
                                = ≤I-pres (pmf x) (≤I-mono (pmf x) (go xs))
      ... | true  | false rewrite +I-assoc (pmf x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (pmf x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (pmf x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (pmf x)
                                | +I-assoc (pmf x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (pmf x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Sum

open import Function

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

record ]0,1[-ops (]0,1[ : Set) (_<E_ : ]0,1[ → ]0,1[ → Set) : Set where
  constructor mk

  field
    -- 1E : ]0,1]
    1+_/1+x_ : ℕ → ℕ → ]0,1[
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[
    1-E_ : ]0,1[ → ]0,1[

   -- proofs <E
  field
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  field
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[){y : ]0,1[} → (x ·E y) <E y
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  -- proofs ≡ maybe should be some Equivalence ≈
  field
    +E-sym : (x y : ]0,1[) → x +E y ≡ y +E x
    +E-assoc : (x y z : ]0,1[) → (x +E y) +E z ≡ x +E (y +E z)
    ·/E-identity : (x : ]0,1[){y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

module ]0,1[-ℚ where
  data ]0,1[ : Set where
    1+_/2+x+_ : ℕ → ℕ → ]0,1[
  -- toℚ : ]0,1] → ℚ
  -- toℚ (1+ x /1+x+ y) = (1 + x) /ℚ (1 + x + y)

  postulate
    _<E_ : ]0,1[ → ]0,1[ → Set
  -- (1+ x /1+x+ y) ≤E (1+ x' /1+x+ y') = ?
  -- (1 + x' + y') * (1 + x) ≤E (1 + x + y) * (1 + x') = ?

  -- 1 - ((1 + x) / (2 + x + y))
  --  ≡ (2 + x + y - (1 + x)) / (2 + x + y)
  --  ≡ (1 + y) / (2 + x + y)
  --  ≡ (1 + y) / (2 + y + x)
  1-E_ : ]0,1[ → ]0,1[
  1-E (1+ x /2+x+ y) = 1+ y /2+x+ x

  -- ((1 + x) / (2 + x + y)) · ((1 + x') / (2 + x' + y'))
  --  ≡ ((1 + x) · (1 + x')) / ((2 + x + y) · (2 + x' + y'))
  --  ≡ (1 + x + x' + x · x') / (4 + 2x + 2y + 2x' + 2y' + xx' + xy' + yx' + yy')
  --  ≡ (1 + (x + x' + xx')) / (2 + (x + x' + xx') + (2 + x + 2y + x' + xy' + yx' + yy'))
  _·E_ : ]0,1[ → ]0,1[ → ]0,1[
  (1+ x /2+x+ y) ·E (1+ x' /2+x+ y') = 1+ x'' /2+x+ y''
    where x'' = x + x' + x * x'
          y'' = 2 + x + 2 * y + x' + x * y' + y * x' + y * y'

  -- ((1 + x) / (2 + x + y)) / ((1 + x') / (2 + x' + y'))
  --   ≡ ((1 + x) · (2 + x' + y')) / ((1 + x') · (2 + x + y))
  --   ≡ (2 + x' + y' + 2x + xx' + xy') / (2 + x + y + 2x' + xx' + x'y)
  --   ≡ (1 + (1 + x' + y' + 2x + xx' + xy')) / (2 + (1 + x' + y' + 2x + xx' + xy') + y + x' + x'y - (1 + y' + x + xy'))
  --   ok provided that:
  --   ((1 + x) / (2 + x + y)) < ((1 + x') / (2 + x' + y'))
  --   implies
  --   (1 + y' + x + xy') ≤ (y + x' + x'y)
  --   which remains to be checked
  _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[
  (1+ x /2+x+ y) /E (1+ x' /2+x+ y') < _ > = 1+ x'' /2+x+ y''
    where x'' = 1 + x' + y' + 2 * x + x * x' + x * y'
          y'' = y + x' + x' * y ∸ 1 ∸ y' ∸ x ∸ x * y'

  postulate
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[

  postulate
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  postulate
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[) {x₁ : ]0,1[} → (x ·E x₁) <E x₁
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  postulate
    +E-sym : (x x₁ : ]0,1[) → x +E x₁ ≡ x₁ +E x
    +E-assoc : (x x₁ x₂ : ]0,1[) → (x +E x₁) +E x₂ ≡ x +E (x₁ +E x₂)
    ·/E-identity : (x : ]0,1[) {y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

  ops : ]0,1[-ops ]0,1[ _<E_
  ops = mk 1+_/2+x+_ _+E_ _·E_ _/E_<_> 1-E_ <E-trans +E-mono₁ +E-mono₂ ·E-anti₁ ·E-anti₂ ·/E-assoc +E-sym +E-assoc ·/E-identity

module [0,1] {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_) where

  open ]0,1[-ops ]0,1[R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   1I : [0,1]
   _I : ]0,1[ → [0,1]

  data _≤I_ : [0,1] → [0,1] → Set where
    z≤n : ∀ {n} → 0I ≤I n
    n≤1 : ∀ {n} → n ≤I 1I
    E≤E : ∀ {x y} → x <E y → (x I) ≤I (y I)
    E≡E : ∀ {x} → x I ≤I x I

  ≤I-refl : ∀ {x} → x ≤I x
  ≤I-refl {0I} = z≤n
  ≤I-refl {1I} = n≤1
  ≤I-refl {x I} = E≡E

  Pos : [0,1] → Set
  Pos 0I    = ⊥
  Pos 1I    = ⊤
  Pos (_ I) = ⊤

  Inc : [0,1] → Set
  Inc 0I = ⊥
  Inc 1I = ⊥
  Inc (x I) = ⊤

  _<_> : (x : [0,1]) → Inc x → ]0,1[
  0I < () >
  1I < () >
  (x I) < pos > = x

  1-I_ : [0,1] → [0,1]
  1-I 0I    = 1I
  1-I 1I    = 0I
  1-I (x I) = (1-E x) I

  _+I_ : [0,1] → [0,1] → [0,1]
  0I  +I x    = x
  x I +I 0I   = x I
  1I  +I _    = 1I -- troublesome
  x I +I 1I   = 1I -- troublesome
  x I +I x₁ I = (x +E x₁) I -- faithful

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  1I ·I y = y
  (x I) ·I 0I     = 0I
  (x I) ·I 1I     = x I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  -- 1/I1+_ : ℕ → [0,1]

  _/I_<_,_> : (x y : [0,1]) → x ≤I y → Pos y → [0,1]
  x /I 0I    < _        , () >
  x /I 1I    < _        , _  > = x
  0I /I _    < _        , _  > = 0I
  1I /I _ I  < ()       , _  >
  (x I) /I y I < E≤E pf , _  > = (x /E y < pf >) I
  (x I) /I .x I < E≡E   , _  > = 1I

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  *-anti : (x : [0,1]){y z : [0,1]} → y ≤I z → x ·I y ≤I z
  *-anti 0I le = z≤n
  *-anti 1I le = le
  *-anti (x I) z≤n = z≤n
  *-anti (x I) n≤1 = n≤1
  *-anti (x I) (E≤E pf) = E≤E (·E-anti₂ x pf)
  *-anti (x I) E≡E = E≤E (·E-anti₁ x)

  */-assoc : (x y z : [0,1])(pr : y ≤I z)(pos : Pos z) → (x ·I (y /I z < pr , pos >)) ≡ (x ·I y) /I z < *-anti x pr , pos >
  */-assoc x y 0I pr ()
  */-assoc x y 1I pr pos = refl
  */-assoc 0I y (z I) pr pos = refl
  */-assoc 1I y (z I) pr pos = refl
  */-assoc (x I) 0I (z I) pr pos = refl
  */-assoc (x I) 1I (z I) () pos
  */-assoc (x I) (y I) (z I) (E≤E pf) pos = cong _I (·/E-assoc x y z pf)
  */-assoc (x I) (y I) (.y I) E≡E pos = cong _I (·/E-identity x)

  +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
  +I-sym 0I 0I = refl
  +I-sym 0I 1I = refl
  +I-sym 0I (x I) = refl
  +I-sym 1I 0I = refl
  +I-sym 1I 1I = refl
  +I-sym 1I (x I) = refl
  +I-sym (x I) 0I = refl
  +I-sym (x I) 1I = refl
  +I-sym (x I) (y I) = cong _I (+E-sym x y)

  +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)
  +I-assoc 0I y z = refl
  +I-assoc 1I y z = refl
  +I-assoc (x I) 0I z = refl
  +I-assoc (x I) 1I z = refl
  +I-assoc (x I) (y I) 0I = refl
  +I-assoc (x I) (y I) 1I = refl
  +I-assoc (x I) (y I) (z I) = cong _I (+E-assoc x y z)

  ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
  ≤I-trans z≤n le2 = z≤n
  ≤I-trans n≤1 n≤1 = n≤1
  ≤I-trans (E≤E x₁) n≤1 = n≤1
  ≤I-trans (E≤E x₁) (E≤E x₂) = E≤E (<E-trans x₁ x₂)
  ≤I-trans (E≤E x₁) E≡E = E≤E x₁
  ≤I-trans E≡E le2 = le2

  ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
  ≤I-mono 0I {z = z} le rewrite +I-sym z 0I = le
  ≤I-mono 1I {z = z} le rewrite +I-sym z 1I = n≤1
  ≤I-mono (x I) z≤n = z≤n
  ≤I-mono (x I) n≤1 = n≤1
  ≤I-mono (x I) (E≤E x₂) = E≤E (<E-trans x₂ (+E-mono₁ x))
  ≤I-mono (x I) E≡E = E≤E (+E-mono₁ x)

  ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z
  ≤I-pres 0I le = le
  ≤I-pres 1I le = n≤1
  ≤I-pres (x I) {.0I} {0I} z≤n = E≡E
  ≤I-pres (x I) {.0I} {1I} z≤n = n≤1
  ≤I-pres (x I) {.0I} {x₁ I} z≤n = E≤E (+E-mono₁ x₁)
  ≤I-pres (x I) n≤1 = n≤1
  ≤I-pres (x I) (E≤E x₂) = E≤E (+E-mono₂ x x₂)
  ≤I-pres (x I) E≡E = E≡E

module Univ {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_)
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1[R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP pmf []       = 0I
  sumP pmf (x ∷ xs) = (pmf x) +I (sumP pmf xs)

  record Distr : Set where
    constructor _,_
    field
      -- Probability mass function: http://en.wikipedia.org/wiki/Probability_mass_function
      pmf    : U → [0,1]
      sum≡1 : sumP pmf allU ≡ 1I

  module Prob (d : Distr) where
    open Distr d

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then pmf x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    _⊆_ : Event → Event → Set
    A ⊆ B = ∀ x → T(A x) → T(B x)

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    postulate
      Pr-mono : ∀ {A B} → A ⊆ B → Pr[ A ] ≤I Pr[ B ]

    ∪-lem : ∀ {A} B → A ⊆ (A ∪ B)
    ∪-lem {A} _ x with A x
    ... | true = id
    ... | false = λ()

    ∩-lem : ∀ A {B} → (A ∩ B) ⊆ B
    ∩-lem A x with A x
    ... | true  = id
    ... | false = λ()

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < Pr-mono (∩-lem A) , pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (pmf x) (sA₁ xs) (pmf x +I sA₂ xs)
                                | +I-sym (pmf x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (pmf x))
                                = ≤I-pres (pmf x) (≤I-mono (pmf x) (go xs))
      ... | true  | false rewrite +I-assoc (pmf x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (pmf x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (pmf x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (pmf x)
                                | +I-assoc (pmf x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (pmf x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)